From d582c20af35b37406c83c88d283aecbaaa0a6b95 Mon Sep 17 00:00:00 2001
From: Thorn Avery <s@p7.co.nz>
Date: Tue, 20 Apr 2021 14:25:18 +1200
Subject: [PATCH] working 2d animation, but leaks memory

---
 cellularAutomata.cabal   |   8 ++
 nix/cellularAutomata.nix |   8 +-
 src/Automata.hs          |  89 +++++++++++++++
 src/Comonad.hs           |  12 ++
 src/Main.hs              | 284 ++++++++++++-----------------------------------
 src/Spaces.hs            | 176 +++++++++++++++++++++++++++++
 6 files changed, 363 insertions(+), 214 deletions(-)
 create mode 100644 src/Automata.hs
 create mode 100644 src/Comonad.hs
 create mode 100644 src/Spaces.hs

diff --git a/cellularAutomata.cabal b/cellularAutomata.cabal
index 5e84036..eeb7cdb 100644
--- a/cellularAutomata.cabal
+++ b/cellularAutomata.cabal
@@ -18,6 +18,8 @@ build-type:          Simple
 
 executable cellularAutomata
   main-is:             Main.hs
+  ghc-options:       -threaded
+                     -O2
   -- other-modules:
   -- other-extensions:
   build-depends:       base >=4.13 && <4.14
@@ -25,6 +27,12 @@ executable cellularAutomata
                      , turtle
                      , brick
                      , process
+                     , containers
+                     , linear
+                     , microlens
+                     , microlens-th
+                     , vty
+                     , deepseq
   hs-source-dirs:      src
   default-language:    Haskell2010
   extra-libraries:     ncurses
diff --git a/nix/cellularAutomata.nix b/nix/cellularAutomata.nix
index bfa6576..6a91002 100644
--- a/nix/cellularAutomata.nix
+++ b/nix/cellularAutomata.nix
@@ -1,4 +1,5 @@
-{ mkDerivation, base, brick, lib, ncurses, process, random, turtle
+{ mkDerivation, base, brick, containers, deepseq, lib, linear
+, microlens, microlens-th, ncurses, process, random, turtle, vty
 }:
 mkDerivation {
   pname = "cellularAutomata";
@@ -6,7 +7,10 @@ mkDerivation {
   src = ./..;
   isLibrary = false;
   isExecutable = true;
-  executableHaskellDepends = [ base brick process random turtle ];
+  executableHaskellDepends = [
+    base brick containers deepseq linear microlens microlens-th process
+    random turtle vty
+  ];
   executableSystemDepends = [ ncurses ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;
diff --git a/src/Automata.hs b/src/Automata.hs
new file mode 100644
index 0000000..6d22f9a
--- /dev/null
+++ b/src/Automata.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Automata where
+
+import Comonad
+import Spaces
+import System.Random
+import GHC.Generics
+import Control.DeepSeq
+
+-----------------------
+-- cellular automata --
+-----------------------
+
+-- the states our cells can be in
+-- may need to provide an ordering
+-- may need to generalise the number
+-- of states
+data CellState = Rock | Paper | Scissors
+  deriving (Eq, Bounded, Enum, Generic)
+
+instance NFData CellState
+
+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
+-- rather than hardcoded
+instance Show CellState
+  where
+    show Rock = "⬤"
+    show Paper = " "
+    show Scissors = "_"
+
+-- -- a rule stating how a cell is determined
+-- rule :: Space CellState -> CellState
+-- rule (Space (l:_) _ (r:_))
+--   | l == r = Dead
+--   | otherwise = Alive
+-- 
+-- -- a second rule for example
+-- rule2 :: Space CellState -> CellState
+-- rule2 (Space (l1:l2:_) m (r1:r2:_))
+--   | m == Alive && numAlive == 1 = Dead
+--   | m == Alive && numAlive == 4 = Dead
+--   | m == Dead && numAlive == 3 = Alive
+--   | otherwise = m
+--   where
+--     ns = [l1, l2, r1, r2]
+--     numAlive = length $ filter (== Alive) ns
+-- 
+-- rule3 :: Space CellState -> CellState
+-- rule3 (Space (l:_) m (r:_))
+--   | l == r = m
+--   | otherwise = if m == Alive then Dead else Alive
+
+--------------
+-- 2d rules --
+--------------
+
+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
+  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:_))
+--  = 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
diff --git a/src/Comonad.hs b/src/Comonad.hs
new file mode 100644
index 0000000..746bfca
--- /dev/null
+++ b/src/Comonad.hs
@@ -0,0 +1,12 @@
+module Comonad where
+
+-------------------
+-- comonad class --
+-------------------
+
+class Functor w => Comonad w
+  where
+    (=>>)     :: w a -> (w a -> b) -> w b
+    extract   :: w a -> a
+    duplicate :: w a -> w (w a)
+    x =>> f = fmap f (duplicate x)
diff --git a/src/Main.hs b/src/Main.hs
index 1d2d2ce..17a52a8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
 import Control.Monad
@@ -6,122 +8,45 @@ import System.Random
 import System.Console.GetOpt
 import System.Environment(getArgs, getProgName)
 import Data.Maybe (fromMaybe)
+import Comonad
+import Spaces
+import Automata
+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 Control.Applicative
+import Control.Monad.IO.Class
+import Control.Concurrent
+import Control.DeepSeq
 
--------------------
--- comonad class --
--------------------
+-----------------
+-- brick stuff --
+-----------------
 
-class Functor w => Comonad w
-  where
-    (=>>)     :: w a -> (w a -> b) -> w b
-    extract   :: w a -> a
-    duplicate :: w a -> w (w a)
-    x =>> f = fmap f (duplicate x)
+data Tick = Tick
+type Name = ()
 
-------------
--- spaces --
-------------
+-- App definition
 
--- a locally focussed space
-data Space t = Space [t] t [t]
+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
+          }
 
--- spaces are also functors
-instance Functor Space where
-  fmap f (Space l c r) = Space (map f l) (f c) (map f r)
+-- Handling events
 
--- our space is a comonad
-instance Comonad Space where
-  -- duplicate will create a new space where
-  -- the focussed element is our original space
-  -- and each side is increasingly shifted copies
-  -- in that direction
-  duplicate w =
-    Space (tail $ iterate left w)
-          w
-          (tail $ iterate right w)
-  -- extract simply returns the focussed element
-  extract (Space _ c _) = c
-
--- functions for moving the point
--- of locality.
--- todo: question the empty list cases
--- most spaces should be infinite
-right :: Space t -> Space t
-right s@(Space l c []) = s
-right (Space l c (r:rs)) = Space (c:l) r rs
-
-left :: Space t -> Space t
-left s@(Space [] c r) = s
-left (Space (l:ls) c r) = Space ls l (c:r)
-
--- bound will take an infinite space
--- and bound it by i and j on each side
--- (not including the focus) and
--- turn it into a list for printing
-bound :: Int -> Int -> Space t -> [t]
-bound i j (Space l c r) = (reverse (take i l)) ++ (c:(take j r))
-
--- boundw works as above, but the
--- entire list will be the size
--- given
-boundw :: Int -> Space t -> [t]
-boundw n = bound (x-m) x
-  where
-    o = if odd n then 1 else 0
-    m = if even n then 1 else 0
-    x = (n - o) `div` 2
-
------------------------
--- cellular automata --
------------------------
-
--- the states our cells can be in
--- may need to provide an ordering
--- may need to generalise the number
--- of states
-data CellState = Alive | Dead
-  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
--- rather than hardcoded
-instance Show CellState
-  where
-    show Alive = "█"
-    show Dead = " "
-
--- a rule stating how a cell is determined
-rule :: Space CellState -> CellState
-rule (Space (l:_) _ (r:_))
-  | l == r = Dead
-  | otherwise = Alive
-
--- a second rule for example
-rule2 :: Space CellState -> CellState
-rule2 (Space (l1:l2:_) m (r1:r2:_))
-  | m == Alive && numAlive == 1 = Dead
-  | m == Alive && numAlive == 4 = Dead
-  | m == Dead && numAlive == 3 = Alive
-  | otherwise = m
-  where
-    ns = [l1, l2, r1, r2]
-    numAlive = length $ filter (== Alive) ns
-
-rule3 :: Space CellState -> CellState
-rule3 (Space (l:_) m (r:_))
-  | l == r = m
-  | otherwise = if m == Alive then Dead else Alive
-
--- take a space and a rule and
--- return the next space
-step :: Comonad w => (w t -> t) -> w t -> w t
-step f w = w =>> f
+theMap :: AttrMap
+theMap = attrMap V.defAttr
+  [ (rockAttr, V.red `on` V.blue)
+  , (scissorsAttr, V.green `on` V.red)
+  , (paperAttr, V.blue `on` V.green)
+  ]
 
 ---------------
 -- rng stuff --
@@ -134,74 +59,6 @@ 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 --
 -----------------
@@ -262,47 +119,50 @@ parseArgs = do
         header = "Usage: " ++ progName ++ " [OPTION...]"
         helpMessage = usageInfo header options
 
+initGame :: IO (Space2 CellState)
+initGame = do
+  rng <- getStdGen
+  return $ createRandSpace2 rng
+
 ---------------
 -- 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 :: Space2 CellState -> Int -> Int -> IO ()
---runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s
---runAutomata s n w = do
---  mapM_ putStrLn $ map show $ concat $ bound2w w s
---  runAutomata (step conway s) (n - 1) w
-
 main :: IO ()
 main = do
   options <- parseArgs
-  rng <- getStdGen
-  let cs = map (\x -> if x then Alive else Dead) $ ilobs rng
   let w = (optWidth options)
   let h = (optHeight options)
-  let g = (optGenerations options)
-  let s = createRandSpace2 rng
-  mapM_ (f w h) (loop conway g s)
+  chan <- newBChan 1
+  forkIO $ forever $ do
+    writeBChan chan Tick
+    threadDelay 100000
+  g <- initGame
+  let buildVty = V.mkVty V.defaultConfig
+  initialVty <- buildVty
+  void $ customMain initialVty buildVty (Just chan) (app h w) (clamp2cw 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
-    f w h s = do
-      mapM_ putStrLn $ map (concat . (map show)) $ bound2w w h s
-      putStrLn (take w (repeat '-'))
-    loop f n s = take n $ iterate (step f) s
+    bw = bound2cw w h 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"
diff --git a/src/Spaces.hs b/src/Spaces.hs
new file mode 100644
index 0000000..b6825c7
--- /dev/null
+++ b/src/Spaces.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Spaces where
+
+import Comonad
+import System.Random
+import Control.DeepSeq
+import GHC.Generics
+
+------------
+-- spaces --
+------------
+
+-- a locally focussed space
+data Space t = Space [t] t [t]
+  deriving (Generic, Generic1)
+
+instance NFData a => NFData (Space a)
+instance NFData1 Space
+
+-- spaces are also functors
+instance Functor Space where
+  fmap f (Space l c r) = Space (map f l) (f c) (map f r)
+
+-- our space is a comonad
+instance Comonad Space where
+  -- duplicate will create a new space where
+  -- the focussed element is our original space
+  -- and each side is increasingly shifted copies
+  -- in that direction
+  duplicate w =
+    Space (tail $ iterate left w)
+          w
+          (tail $ iterate right w)
+  -- extract simply returns the focussed element
+  extract (Space _ c _) = c
+
+-- functions for moving the point
+-- of locality.
+-- todo: question the empty list cases
+-- most spaces should be infinite
+right :: Space t -> Space t
+right w@(Space l m []) = w
+right (Space l c (r:rs)) = Space (c:l) r rs
+
+left :: Space t -> Space t
+left w@(Space [] m r) = w
+left (Space (l:ls) c r) = Space ls l (c:r)
+
+-- bound will take an infinite space
+-- and bound it by i and j on each side
+-- (not including the focus) and
+-- turn it into a list for printing
+bound :: Int -> Int -> Space t -> [t]
+bound i j (Space l c r) = (reverse (take i l)) ++ (c:(take j r))
+
+-- boundw works as above, but the
+-- entire list will be the size
+-- given
+boundw :: Int -> Space t -> [t]
+boundw n = bound (x-m) x
+  where
+    o = if odd n then 1 else 0
+    m = if even n then 1 else 0
+    x = (n - o) `div` 2
+
+---------------
+-- 2d spaces --
+---------------
+
+data Space2 t =
+  Space2 [(Space t)]
+          (Space t)
+         [(Space t)]
+  deriving (Generic, Generic1)
+
+instance NFData a => NFData (Space2 a)
+instance NFData1 Space2
+
+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
+
+bound2cw :: NFData t => Int -> Int -> Space2 t -> [[t]]
+bound2cw x y w = bound2 (r-q) r (n-m) n $ clamp2 (r-q+1) (r+1) (n-m+1) (n+1) w
+  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
+
+clamp2cw :: NFData t => Int -> Int -> Space2 t -> Space2 t
+clamp2cw x y w = clamp2 (r-q+1) (r+1) (n-m+1) (n+1) w
+  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
+
+clamp2 :: NFData t => Int -> Int -> Int -> Int -> Space2 t -> Space2 t
+clamp2 u d l r (Space2 uw mw dw)
+  = force $ Space2 (take u $ fmap (clamp l r) uw)
+           (clamp l r mw)
+           (take d $ fmap (clamp l r) dw)
+
+clamp :: NFData t => Int -> Int -> Space t -> Space t
+clamp x y (Space l m r) = force $ Space (take x l) m (take y r)
+
+-- take a space and a rule and
+-- return the next space
+step :: Comonad w => (w t -> t) -> w t -> w t
+step f w = w =>> f
+
+-------------------
+-- Random Spaces --
+-------------------
+
+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