module CellularAutomata where

{- Cellular Automata embedded DSL in Haskell
 - 
 - functions available:
 -      at, if_, cond_, +, *, .: (cons), nil, 
 -      .&& (logical AND), .|| (logical OR), .== (equality)
 -}

import Array

main = 
  do printCell2D $ take 5  $ simAutomata life glider
     printCell1D $ take 20 $ simAutomata rule90 $ 
                                         initialize (0,60) ' ' [(30,'*')]

{- Life.  Compare with Cellang...
 - 
 -   2 dimensions of 0..1
 -
 -   sum := [0, 1] + [1, 1] + [1, 0] + [-1, 1] + [-1, 0] + 
 -          [-1, -1] + [0, -1] + [1, -1]
 -
 -   cell := 1 when (sum = 2 & cell = 1) | sum = 3
 -        := 0 otherwise
 -
 -}
lsum = at (-1, 1) + at (0, 1) + at (1, 1) +
       at (-1, 0) +             at (1, 0) +
       at (-1,-1) + at (0,-1) + at (1,-1)  

life = if_ (lsum .== 2 .&& at (0,0) .== 1 .|| lsum .== 3) 1 0
          
glider = initialize ((0,0),(4,4)) 0 [          ((1,0),1),
                                                         ((2,1),1),
                                     ((0,2),1),((1,2),1),((2,2),1)]

-- Rule90
rule90 = case_ (at (-1) .: at 0 .: at 1 .: nil)
               [("   ", ' '),
                ("  *", '*'),
                (" * ", ' '),
                (" **", '*'),
                ("*  ", '*'),
                ("* *", ' '),
                ("** ", '*'),
                ("***", ' ')]

-- Main stuff
type State val idx = ((Array idx val),idx)
data Cell a b c = Cell (State b c-> (a,State b c))

simAutomata f = iterate $ \a -> array (bounds a) $ 
                                map (\i->(i,fst (runCell f (a,i)))) (indices a)

runCell (Cell f) state = f state

arr !. i = arr ! (i `mod` range + lower)
    where 
        (lower,upper) = bounds arr
        range = (upper - lower) + 1

initialize bnds val outliers = (listArray bnds (repeat val)) // outliers

-- Convert regular functions to work in the Cell domain...
lift0 x                   = Cell (\s -> (x,s))
lift1 f (Cell g)          = Cell (\s -> (f (fst (g s)),s))
lift2 f (Cell a) (Cell b) = Cell (\s -> (f (fst (a s)) (fst (b s)), s))
lift3 f (Cell a) (Cell b) (Cell c) = 
    Cell $ \s -> (f (fst (a s)) (fst (b s)) (fst (c s)),s)

at offset_idx = Cell $ \(arr,base_idx) -> 
                        (arr !. (base_idx + offset_idx),(arr,base_idx))

if_ = lift3 (\p t f -> if p then t else f)

case_ :: (Eq a) => Cell a c d -> [(a,b)] -> Cell b c d
case_ (Cell obj) lst = 
   Cell $ \st -> ((snd.head) (filter (\x -> (fst x) == (fst (obj st))) lst),st)

infixr 5 .:
(.:)  = lift2 (:)
nil = lift0 []
infixr 2 .||
(.||) = lift2 (||)
infixr 3 .&&
(.&&) = lift2 (&&)
infix 4 .==
(.==) :: Eq a => Cell a b c -> Cell a b c -> Cell Bool b c
(.==) = lift2 (==)

--Misc. helper funcs...
printCell1D x = putStr $ unlines $ map show1D x
show1D arr = map (\i -> arr!i) (indices arr)

printCell2D x = putStr $ unlines $ map show2D x
show2D arr = unlines $ map show [[arr ! (x,y)| x <- [lx..hx]] | y <- [ly..hy]]
    where ((lx,ly),(hx,hy)) = bounds arr

--Type class declarations...
--Cells
instance (Show a) => Show (Cell a b c) where show x = error "show not impl. yet"
instance Eq (Cell a b c) where (==) = error "== not impl. yet"
instance Num a => Num (Cell a b c) where
    (+) = lift2 (+)
    (*) = lift2 (*)
    abs = lift1 abs
    signum = lift1 signum
    fromInteger = lift0 . fromInteger

--Array indices...
--2D
instance (Num a, Ix a, Num b, Ix b) => Num ((,) a b) where
    (a,b) + (c,d) = (a+c,b+d)
    (a,b) - (c,d) = (a-c,b-d)
    fromInteger x = (fromInteger x,fromInteger x)
instance (Integral a, Ix a, Integral b, Ix b) => Integral ((,) a b) where
    (a,b) `mod` (c,d) = (a `mod` c, b `mod` d)
instance (Real a, Ix a, Real b, Ix b) => Real ((,) a b)
instance (Real a, Ix a, Real b, Ix b) => Enum ((,) a b)