clean up + easier rule generation

src/Automata.hs

@@ -8,6 +8,7 @@ import Spaces.Space2
 import System.Random
 import GHC.Generics
 import Control.DeepSeq
+import Data.Maybe
 
 -----------------------
 -- cellular automata --
@@ -59,32 +60,77 @@ instance Show CellState
 --   | l == r = m
 --   | otherwise = if m == Alive then Dead else Alive
 
+------------------------
+-- grabbing neighbors --
+------------------------
+
+-- we want to be able to create a list of (Maybe CellState)
+-- representing each neighbor, this way it will work on the
+-- edges, and also we can fix the position of ecah neighbor
+-- so that rules can be directional also.
+
+grabNeighbors :: Space2 CellState -> [(Maybe CellState)]
+grabNeighbors s = let
+  tl = grabTopLeft s
+  t  = grabTop s
+  tr = grabTopRight s
+  l  = grabLeft s
+  r  = grabRight s
+  bl = grabBotLeft s
+  b  = grabBot s
+  br = grabBotRight s
+  in [tl, t, tr, l, r, bl, b, br]
+
+grabTemplate :: (Space2 CellState -> Maybe (Space2 CellState))
+  -> Space2 CellState -> Maybe CellState
+grabTemplate f s = case f s of
+  Nothing -> Nothing
+  Just x -> Just $ extract x
+
+grabTop, grabBot, grabLeft, grabRight :: Space2 CellState -> Maybe CellState
+grabTop = grabTemplate up2
+grabBot = grabTemplate down2
+grabLeft = grabTemplate left2
+grabRight = grabTemplate right2
+
+maycom :: (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a
+maycom f g s = do
+  x <- f s
+  y <- g x
+  return y
+
+grabTopLeft, grabTopRight, grabBotLeft, grabBotRight :: Space2 CellState -> Maybe CellState
+grabTopLeft = grabTemplate (maycom up2 left2)
+grabTopRight = grabTemplate (maycom up2 right2)
+grabBotLeft = grabTemplate (maycom down2 left2)
+grabBotRight = grabTemplate (maycom down2 right2)
+
+filtJust :: [(Maybe a)] -> [a]
+filtJust [] = []
+filtJust (Nothing:as) = filtJust as
+filtJust ((Just a):as) = a:(filtJust as)
+
+numMatch :: CellState -> [(Maybe CellState)] -> Int
+numMatch c = length . (filter (== c)) . filtJust
+
 --------------
 -- 2d rules --
 --------------
 
+conway :: Space2 CellState -> CellState
+conway s = case extract s of
+  Rock -> Paper
+  Paper -> if numSci == 3 then Scissors else Paper
+  Scissors -> if numSci == 2 || numSci == 3 then Scissors else Paper
+  where
+    numSci = numMatch Scissors ns
+    ns = grabNeighbors s
+
 rps :: Space2 CellState -> CellState
-rps (Space2 u m d)
-  = case me of
-      Rock -> if (length $ filter (== Paper) ns) > 2 then Paper else Rock
-      Paper -> if (length $ filter (== Scissors) ns) > 2 then Scissors else Paper
-      Scissors -> if (length $ filter (== Rock) ns) > 2 then Rock else Scissors
+rps s
+  = case extract s of
+      Rock -> if (numNs Paper) > 2 then Paper else Rock
+      Paper -> if (numNs Scissors) > 2 then Scissors else Paper
+      Scissors -> if (numNs Rock) > 2 then Rock else Scissors
   where
-    f b (Space (l:_) m (r:_)) = [l,r] ++ (if b then [m] else [])
-    f b (Space [] m (r:_)) = [r] ++ (if b then [m] else [])
-    f b (Space (l:_) m []) = [l] ++ (if b then [m] else [])
-    f b (Space [] m []) = if b then [m] else []
-    safeHead _ [] = []
-    safeHead b (x:_) = f b x
-    ns = concat [ (safeHead True u), (f False m), (safeHead True d) ]
-    me = extract m
-
---conway :: Space2 CellState -> CellState
---conway (Space2 (u:_) m (d:_))
+    numNs c = numMatch c $ grabNeighbors s

src/BrickStuff.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module BrickStuff where
+
+import Automata
+import Spaces.Space2
+
+import System.Random
+import Brick
+import Brick.BChan (newBChan, writeBChan)
+import qualified Brick.Widgets.Border as B
+import qualified Brick.Widgets.Border.Style as BS
+import qualified Brick.Widgets.Center as C
+import qualified Graphics.Vty as V
+
+-----------------
+-- brick stuff --
+-----------------
+
+data Tick = Tick
+type Name = ()
+
+-- App definition
+
+app :: Int -> Int -> App (Space2 CellState) Tick Name
+app h w = App { appDraw = drawUI h w
+          , appChooseCursor = neverShowCursor
+          , appHandleEvent = handleEvent
+          , appStartEvent = return
+          , appAttrMap = const theMap
+          }
+
+-- Handling events
+
+theMap :: AttrMap
+theMap = attrMap V.defAttr
+  [ (rockAttr, V.red `on` V.blue)
+  , (scissorsAttr, V.green `on` V.red)
+  , (paperAttr, V.blue `on` V.green)
+  ]
+
+handleEvent :: (Space2 CellState) -> BrickEvent Name Tick -> EventM Name (Next (Space2 CellState))
+handleEvent g (AppEvent Tick) = continue $ step rps g
+handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g
+handleEvent g _ = continue g
+
+drawUI :: Int -> Int -> Space2 CellState -> [Widget Name]
+drawUI h w g = [ C.center $ drawGrid h w g ]
+
+drawGrid :: Int -> Int -> Space2 CellState -> Widget Name
+drawGrid h w g = vBox rows
+  where
+    bw = mat2 g   
+    rows = [ hBox $ cellsInRow r | r <- bw ]
+    cellsInRow y = map drawCell y
+
+drawCell :: CellState -> Widget Name
+drawCell Paper = withAttr paperAttr $ str " "
+drawCell Scissors = withAttr scissorsAttr $ str " "
+drawCell Rock = withAttr rockAttr $ str " "
+
+rockAttr, scissorsAttr, paperAttr :: AttrName
+rockAttr = "rockAttr"
+paperAttr = "paperAttr"
+scissorsAttr = "scissorsAttr"
+
+initGame :: IO (Space2 CellState)
+initGame = do
+  rng <- getStdGen
+  return $ createRandSpace2 rng

src/Main.hs

@@ -1,129 +1,18 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main where
 
-import Control.Monad
-import System.Process
-import System.Random
-import System.Console.GetOpt
-import System.Environment(getArgs, getProgName)
-import Data.Maybe (fromMaybe)
 import Comonad
-import Spaces.Space2
-import Spaces.Space1
 import Automata
+import BrickStuff
+import Options
+import Spaces.Space2
+
 import Brick
-import Brick.BChan (newBChan, writeBChan)
-import qualified Brick.Widgets.Border as B
-import qualified Brick.Widgets.Border.Style as BS
-import qualified Brick.Widgets.Center as C
-import qualified Graphics.Vty as V
+import Brick.BChan
+import Control.Monad
 import Control.Applicative
 import Control.Monad.IO.Class
 import Control.Concurrent
-import Control.DeepSeq
-
------------------
------------------
-
-data Tick = Tick
-type Name = ()
-
-
-app :: Int -> Int -> App (Space2 CellState) Tick Name
-app h w = App { appDraw = drawUI h w
-          , appChooseCursor = neverShowCursor
-          , appHandleEvent = handleEvent
-          , appStartEvent = return
-          , appAttrMap = const theMap
-          }
-
-
-theMap :: AttrMap
-theMap = attrMap V.defAttr
-  [ (rockAttr, V.red `on` V.blue)
-  , (scissorsAttr, V.green `on` V.red)
-  , (paperAttr, V.blue `on` V.green)
-  ]
-
----------------
----------------
-
-ilobs :: StdGen -> [Bool]
-ilobs rng = b : (ilobs r)
-  where
-    (b,r) = random rng
-
------------------
------------------
-
-
-------------------------
-------------------------
-
-data Options = Options
-  { optWidth       :: Int
-  , optGenerations :: Int
-  , optHeight      :: Int
-  } deriving Show
-
-defaultOptions :: Int -> Int -> Options
-defaultOptions w h = Options
-  { optWidth       = w
-  , optGenerations = 40
-  , optHeight      = h
-  }
-
-options :: [OptDescr (Options -> Options)]
-options =
-  [ Option ['w'] ["width"]
-      (ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
-      "term width"
-  , 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"
-  ]
-
-parseArgs :: IO Options
-parseArgs = do
-  argv <- getArgs
-  progName <- getProgName
-  tw <- readProcess "tput" [ "cols" ] ""
-  th <- readProcess "tput" [ "lines" ] ""
-  case getOpt RequireOrder options argv of
-    (opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
-    (_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
-      where
-        header = "Usage: " ++ progName ++ " [OPTION...]"
-        helpMessage = usageInfo header options
-
-initGame :: IO (Space2 CellState)
-initGame = do
-  rng <- getStdGen
-  return $ createRandSpace2 rng
+import qualified Graphics.Vty as V
 
 ---------------
 -- main loop --
@@ -137,51 +26,9 @@ main = do
   chan <- newBChan 1
   forkIO $ forever $ do
     writeBChan chan Tick
-    threadDelay 100000
+    threadDelay 70000
   g <- initGame
   let buildVty = V.mkVty V.defaultConfig
   initialVty <- buildVty
   void $ customMain initialVty buildVty (Just chan) (app h w) (clamp2 w h g)
 
-handleEvent :: (Space2 CellState) -> BrickEvent Name Tick -> EventM Name (Next (Space2 CellState))
-handleEvent g (AppEvent Tick) = continue $ step rps g
-handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g
-handleEvent g _ = continue g
-
-drawUI :: Int -> Int -> Space2 CellState -> [Widget Name]
-drawUI h w g = [ C.center $ drawGrid h w g ]
-
-drawGrid :: Int -> Int -> Space2 CellState -> Widget Name
-drawGrid h w g = vBox rows
-  where
-    bw = mat2 g   
-    rows = [ hBox $ cellsInRow r | r <- bw ]
-    cellsInRow y = map drawCell y
-
-drawCell :: CellState -> Widget Name
-drawCell Paper = withAttr paperAttr $ str " "
-drawCell Scissors = withAttr scissorsAttr $ str " "
-drawCell Rock = withAttr rockAttr $ str " "
-
-rockAttr, scissorsAttr, paperAttr :: AttrName
-rockAttr = "rockAttr"
-paperAttr = "paperAttr"
-scissorsAttr = "scissorsAttr"
-
-createRandSpace :: Random a => StdGen -> Space a
-createRandSpace rng =
-  Space (tail $ map snd $ iterate f (r1, (fst (random rng))))
-        (fst (random rng))
-        (tail $ map snd $ iterate f (r2, (fst (random rng))))
-  where
-    f (r,b) = let (nb,nr) = (random r) in (nr,nb)
-    (r1,r2) = split rng
-
-createRandSpace2 :: Random a => StdGen -> Space2 a
-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

src/Options.hs

@@ -0,0 +1,56 @@
+module Options where
+
+import System.Environment
+import System.Console.GetOpt
+import System.Process
+
+------------------------
+-- command line flags --
+------------------------
+
+-- structure containing the programs options
+data Options = Options
+  { optWidth       :: Int
+  , optGenerations :: Int
+  , optHeight      :: Int
+  } deriving Show
+
+-- the default options for the program
+-- the width and generations are injected
+-- and intended to be gotten at runtime
+-- to match the window dimensions
+defaultOptions :: Int -> Int -> Options
+defaultOptions w h = Options
+  { optWidth       = w
+  , optGenerations = 40
+  , optHeight      = h
+  }
+
+-- the avaliable options
+options :: [OptDescr (Options -> Options)]
+options =
+  [ Option ['w'] ["width"]
+      (ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
+      "term width"
+  , 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
+-- erroring if encountering a flag not known to us
+parseArgs :: IO Options
+parseArgs = do
+  argv <- getArgs
+  progName <- getProgName
+  tw <- readProcess "tput" [ "cols" ] ""
+  th <- readProcess "tput" [ "lines" ] ""
+  case getOpt RequireOrder options argv of
+    (opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
+    (_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
+      where
+        header = "Usage: " ++ progName ++ " [OPTION...]"
+        helpMessage = usageInfo header options

src/Spaces/Space1.hs

@@ -3,6 +3,8 @@
 module Spaces.Space1 where
 
 import Comonad
+
+import System.Random
 import Control.DeepSeq
 import GHC.Generics
 
@@ -65,3 +67,12 @@ mat (Space l m r) = (reverse l) ++ (m:r)
 matn :: Int -> Space t -> [t]
 matn n = mat . (clamp n)
 
+-- create a randomly filled space
+createRandSpace :: Random a => StdGen -> Space a
+createRandSpace rng =
+  Space (tail $ map snd $ iterate f (r1, (fst (random rng))))
+        (fst (random rng))
+        (tail $ map snd $ iterate f (r2, (fst (random rng))))
+  where
+    f (r,b) = let (nb,nr) = (random r) in (nr,nb)
+    (r1,r2) = split rng

src/Spaces/Space2.hs

@@ -3,10 +3,12 @@
 module Spaces.Space2 where
 
 import Comonad
+import Spaces.Space1
+
+import System.Random
 import Data.Maybe
 import Control.DeepSeq
 import GHC.Generics
-import Spaces.Space1
 
 -- a nested space
 data Space2 t = Space2 [(Space t)] (Space t) [(Space t)]
@@ -36,16 +38,16 @@ f g (Space l m r) = case (g m) of
 
 -- comonad instance for our 2d space
 instance Comonad Space2 where
-  duplicate w =
-    Space2 (finterate (f up2) dm) dm (finterate (f down2) dm)
-      where
-        dm = Space (finterate left2 w) w (finterate right2 w)
   -- to duplicate we must recursively duplicate in all directions
   -- the focussed space becomes the whole space, with left and right
   -- mapped to each side.
   -- to do the up and down lists, each needs to be the middle space
   -- mapped up and down as far as we can.
   -- up2 and down2 will return Nothing when they cant go further
+  duplicate w =
+    Space2 (finterate (f up2) dm) dm (finterate (f down2) dm)
+      where
+        dm = Space (finterate left2 w) w (finterate right2 w)
   -- to extract we simply recursively extract
   extract (Space2 _ m _) = extract m
 
@@ -108,3 +110,13 @@ matn2 w h = mat2 . (clamp2 w h)
 
 step :: Comonad w => (w t -> t) -> w t -> w t
 step f w = w =>> f
+
+-- create a randomly filled space
+createRandSpace2 :: Random a => StdGen -> Space2 a
+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