{-# OPTIONS -fglasgow-exts #-}
-- for parallel list comprehensions

module GraphLife where

import Random
import Array

data Cell v n = Cell { value     :: v,
                       neighbors :: n (Cell v n),
                       future    :: Cell v n }

-- Build a cell and its chain of futures, given its rule, similar neighbors, and initial value.
mkCell :: Functor n => (v -> n v -> v) -> v -> n (Cell v n) -> Cell v n
mkCell rule val nei = initial
  where initial = Cell val nei (calcFuture initial)
        calcFuture c = c'
          where c' = Cell (rule (value c) (fmap value (neighbors c)))
                          (fmap future (neighbors c))
                          (calcFuture c')

---------------------------------------------------------------------------

-- a simple fold for most uses of neighborhoods
class NFoldable n where
  foldN :: (a -> a -> a) -> n a -> a

class Neighborhood2D n where
  gridToNeighbors :: (Int -> Int -> a) -> n a
    
sumN f n = foldN (+) $ fmap f n

---------------------------------------------------------------------------

-- A Moore neighborhood: eight cells around a cell on a 2D grid.
data Moore c = Moore c c c c c c c c

instance Functor Moore where
  fmap f (Moore a b c d e g h i) = 
    Moore (f a) (f b) (f c) (f d) (f e) (f g) (f h) (f i)

instance NFoldable Moore where
  foldN (+) (Moore a b c d e g h i) = a + b + c + d + e + g + h + i

instance Neighborhood2D Moore where
  gridToNeighbors seek = Moore
    (seek (-1) (-1)) (seek 0 (-1)) (seek 1 (-1))
    (seek (-1)   0 )               (seek 1   0 )
    (seek (-1)   1 ) (seek 0   1 ) (seek 1   1 )

right (Cell _ (Moore _ _ _
                     _   c
                     _ _ _) _) = c
down  (Cell _ (Moore _ _ _
                     _   _
                     _ c _) _) = c

---------------------------------------------------------------------------

-- Build a torus of randomly-valued cells, using an array to lookup each cell's neighboring cells efficiently.
buildRandomTorus rule w h gen = cs ! (0,0)
  where cs = array ((0,0), (pred w, pred h))
               [((x,y), mkCell rule r (gridToNeighbors seek))
                | x <- [0..pred w],
                  y <- [0..pred h],
                  let seek dx dy = cs ! ((x + dx) `mod` w, 
                                         (y + dy) `mod` h)
                | r <- randoms gen]

-- This doesn't work. I haven't gotten around to figuring out why yet.
-- It should generate an empty rectangle with a border of randomly-valued cells.
buildNoiseBorderedRect rule w h gen = cs ! (0,0)
  where cs = array ((-1,-1), (w, h))
               ([((x,y), mkCell rule (toEnum 0) (gridToNeighbors seek))
                 | x <- [0..pred w],
                   y <- [0..pred h],
                   let seek dx dy = cs ! ((x + dx) `mod` w, 
                                          (y + dy) `mod` h)]
                ++ [((x, y), mkCell const r (gridToNeighbors seek))
                    | x <- [-1..w]
                        ++ [-1..w]
                        ++ replicate h (-1)
                        ++ replicate h w,
                      y <- replicate (w+2) (-1)
                        ++ replicate (w+2) h
                        ++ [0..pred h]
                        ++ [0..pred h],
                      let seek dx dy = cs ! ((x + dx) `mod` w, 
                                             (y + dy) `mod` h)
                    | r <- randoms gen])

---------------------------------------------------------------------------

-- Conway's Life
evalLife :: Bool -> Moore Bool -> Bool
evalLife v n = f v (sumN fromEnum n)
  where f _    3 = True
        f True 2 = True
        f _    _ = False

---------------------------------------------------------------------------

-- simple routine to draw a Bool-valued grid
lprint w h c = mapM_ putStrLn $ map (map terp . take w . iterate right) $ take h $ iterate down c

terp c = if (value c) then '#' else ' '

animateMoore :: Int -> Int -> Cell Bool Moore -> IO ()
animateMoore w h = mapM_ (lprint w h) . iterate future

demo = do g <- newStdGen
          animateMoore 70 10 (buildRandomTorus evalLife 70 10 g)