2d automata

README.md

@@ -1,7 +1,14 @@
 # cellularAutomata
 
+!!! WARNING !!!
+this will probably leak memory until i write a clamp function
+also this readme is out of date
+!!! WARNING !!!
+
 a small application for running a one-dimensional cellular automata from random inputs, using comonads
 
+now also supports 2d automata, check out [here](conwayExample.txt) for an example of the current output of the program
+
 ## usage
 
 the program will default to the size of the window

src/Main.hs

@@ -1,6 +1,5 @@
 module Main where
 
---import System.Random
 import Control.Monad
 import System.Process
 import System.Random
@@ -81,7 +80,13 @@ boundw n = bound (x-m) x
 -- may need to generalise the number
 -- of states
 data CellState = Alive | Dead
-  deriving Eq
+  deriving (Eq, Bounded, Enum)
+
+instance Random CellState where
+    random g = case randomR (fromEnum (minBound :: CellState), fromEnum (maxBound :: CellState)) g of
+                 (r, g') -> (toEnum r, g')
+    randomR (a,b) g = case randomR (fromEnum a, fromEnum b) g of
+                        (r, g') -> (toEnum r, g')
 
 -- how the states are displayed on screen
 -- this should probably be input to a function
@@ -115,7 +120,7 @@ rule3 (Space (l:_) m (r:_))
 
 -- take a space and a rule and
 -- return the next space
-step :: (Space t -> t) -> Space t -> Space t
+step :: Comonad w => (w t -> t) -> w t -> w t
 step f w = w =>> f
 
 ---------------
@@ -129,6 +134,74 @@ ilobs rng = b : (ilobs r)
   where
     (b,r) = random rng
 
+-- this is kinda gross but if it works it works
+takeGive :: Int -> [a] -> ([a],[a])
+takeGive n as = ( (take n as), (drop n as) )
+
+--------------------------
+-- 2d cellular automata --
+--------------------------
+
+data Space2 t =
+  Space2 [(Space t)]
+          (Space t)
+         [(Space t)]
+
+instance Functor Space2 where
+  fmap f (Space2 u m d) =
+    Space2 (fmap (fmap f) u) (fmap f m) (fmap (fmap f) d)
+
+instance Comonad Space2 where
+  duplicate w =
+    Space2 (tail $ iterate (f up2) dm)
+           dm
+           (tail $ iterate (f down2) dm)
+    where
+      f g (Space l m r) = Space (fmap g l) (g m) (fmap g r)
+      dm = Space (tail $ iterate left2 w) w (tail $ iterate right2 w)
+  extract (Space2 _ m _) = extract m
+
+down2 :: Space2 t -> Space2 t
+down2 w@(Space2 u m []) = w
+down2 (Space2 u m (d:ds)) = Space2 (m:u) d ds
+
+up2 :: Space2 t -> Space2 t
+up2 w@(Space2 [] m d) = w
+up2 (Space2 (u:us) m d) = Space2 us u (m:d)
+
+left2 :: Space2 t -> Space2 t
+left2 (Space2 u m d) = Space2 (fmap left u) (left m) (fmap left d)
+
+right2 :: Space2 t -> Space2 t
+right2 (Space2 u m d) = Space2 (fmap right u) (right m) (fmap right d)
+
+bound2 :: Int -> Int -> Int -> Int -> Space2 t -> [[t]]
+bound2 u d l r (Space2 uw mw dw) = (reverse (take u (map (bound l r) uw))) ++ ((bound l r mw):(take d (map (bound l r) dw)))
+
+bound2w :: Int -> Int -> Space2 t -> [[t]]
+bound2w x y = bound2 (r-q) r (n-m) n
+  where
+    o = if odd x then 1 else 0
+    m = if even x then 1 else 0
+    n = (x - o) `div` 2
+    p = if odd y then 1 else 0 
+    q = if even y then 1 else 0
+    r = (y - p) `div` 2
+
+--------------
+-- 2d rules --
+--------------
+
+conway :: Space2 CellState -> CellState
+conway (Space2 (u:_) m (d:_))
+  = case me of
+      Alive -> if (length ns) == 2 || (length ns == 3) then Alive else Dead
+      Dead -> if (length ns) == 3 then Alive else Dead
+  where
+    f b (Space (l:_) m (r:_)) = [l,r] ++ (if b then [m] else [])
+    ns = filter (== Alive) $ concat [ (f True u), (f False m), (f True d) ]
+    me = extract m
+
 -----------------
 -- gross io bs --
 -----------------
@@ -146,6 +219,7 @@ ilobs rng = b : (ilobs r)
 data Options = Options
   { optWidth       :: Int
   , optGenerations :: Int
+  , optHeight      :: Int
   } deriving Show
 
 -- the default options for the program
@@ -155,7 +229,8 @@ data Options = Options
 defaultOptions :: Int -> Int -> Options
 defaultOptions w h = Options
   { optWidth       = w
-  , optGenerations = h
+  , optGenerations = 40
+  , optHeight      = h
   }
 
 -- the avaliable options
@@ -167,6 +242,9 @@ options =
   , Option ['g'] ["generations"]
       (ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS")
       "time steps to simulate"
+  , Option ['h'] ["height"]
+      (ReqArg (\t opts -> opts { optHeight = (read t) }) "HEIGHT")
+      "term height"
   ]
 
 -- parse the options into the structure
@@ -188,12 +266,30 @@ parseArgs = do
 -- main loop --
 ---------------
 
+createRandSpace :: StdGen -> Space CellState
+createRandSpace rng =
+  Space (tail $ map snd $ iterate f (r1, Alive))
+        (fst (random rng))
+        (tail $ map snd $ iterate f (r2, Alive))
+  where
+    f (r,b) = let (nb,nr) = (random r) in (nr,nb)
+    (r1,r2) = split rng
+
+createRandSpace2 :: StdGen -> Space2 CellState
+createRandSpace2 rng = 
+  Space2 (tail $ map snd $ iterate f (r1, (createRandSpace r1)))
+         (createRandSpace rng)
+         (tail $ map snd $ iterate f (r2, (createRandSpace r2)))
+  where
+    f (r,s) = let (nr1,nr2) = split r in (nr2, (createRandSpace nr1))
+    (r1,r2) = split rng
+
 -- simply print the current space, then recurse to the next
-runAutomata :: Space CellState -> Int -> Int -> IO ()
+--runAutomata :: Space2 CellState -> Int -> Int -> IO ()
-runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s
+--runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s
-runAutomata s n w = do
+--runAutomata s n w = do
-  putStrLn $ concat $ map show $ boundw w s
+--  mapM_ putStrLn $ map show $ concat $ bound2w w s
-  runAutomata (step rule s) (n - 1) w
+--  runAutomata (step conway s) (n - 1) w
 
 main :: IO ()
 main = do
@@ -201,12 +297,12 @@ main = do
   rng <- getStdGen
   let cs = map (\x -> if x then Alive else Dead) $ ilobs rng
   let w = (optWidth options)
-  let h = (optGenerations options)
+  let h = (optHeight options)
-  let wh = (w + 1) `div` 2
+  let g = (optGenerations options)
-  let m = head cs
+  let s = createRandSpace2 rng
-  let l = take wh $ drop 1 cs
+  mapM_ (f w h) (loop conway g s)
-  let r = take wh $ drop wh $ drop 1 cs
+  where
-  let s = Space (l ++ (repeat Dead)) m (r ++ (repeat Dead))
+    f w h s = do
-  -- non-random starting position for rule3 (the serpinski triangle)
+      mapM_ putStrLn $ map (concat . (map show)) $ bound2w w h s
-  --let s = Space (repeat Dead) Alive (repeat Dead)
+      putStrLn (take w (repeat '-'))
-  runAutomata s h w
+    loop f n s = take n $ iterate (step f) s