From bdda683c42815b3992f6f4b313bcdf44fe07fff3 Mon Sep 17 00:00:00 2001
From: Thorn Avery <s@p7.co.nz>
Date: Tue, 20 Apr 2021 19:44:30 +1200
Subject: [PATCH] working 2d animation, no memory leak

---
 src/Automata.hs      |   3 +-
 src/Main.hs          |  25 +++++++-
 src/Spaces.hs        | 176 ---------------------------------------------------
 src/Spaces/Space1.hs |  67 ++++++++++++++++++++
 src/Spaces/Space2.hs | 110 ++++++++++++++++++++++++++++++++
 5 files changed, 201 insertions(+), 180 deletions(-)
 delete mode 100644 src/Spaces.hs
 create mode 100644 src/Spaces/Space1.hs
 create mode 100644 src/Spaces/Space2.hs

diff --git a/src/Automata.hs b/src/Automata.hs
index 6d22f9a..f8ac173 100644
--- a/src/Automata.hs
+++ b/src/Automata.hs
@@ -3,7 +3,8 @@
 module Automata where
 
 import Comonad
-import Spaces
+import Spaces.Space1
+import Spaces.Space2
 import System.Random
 import GHC.Generics
 import Control.DeepSeq
diff --git a/src/Main.hs b/src/Main.hs
index 17a52a8..ec02c4c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,7 +9,8 @@ import System.Console.GetOpt
 import System.Environment(getArgs, getProgName)
 import Data.Maybe (fromMaybe)
 import Comonad
-import Spaces
+import Spaces.Space2
+import Spaces.Space1
 import Automata
 import Brick
 import Brick.BChan (newBChan, writeBChan)
@@ -140,7 +141,7 @@ main = do
   g <- initGame
   let buildVty = V.mkVty V.defaultConfig
   initialVty <- buildVty
-  void $ customMain initialVty buildVty (Just chan) (app h w) (clamp2cw w h g)
+  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
@@ -153,7 +154,7 @@ 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 = bound2cw w h g   
+    bw = mat2 g   
     rows = [ hBox $ cellsInRow r | r <- bw ]
     cellsInRow y = map drawCell y
 
@@ -166,3 +167,21 @@ 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
diff --git a/src/Spaces.hs b/src/Spaces.hs
deleted file mode 100644
index b6825c7..0000000
--- a/src/Spaces.hs
+++ /dev/null
@@ -1,176 +0,0 @@
-{-# 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
diff --git a/src/Spaces/Space1.hs b/src/Spaces/Space1.hs
new file mode 100644
index 0000000..3f9bbea
--- /dev/null
+++ b/src/Spaces/Space1.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Spaces.Space1 where
+
+import Comonad
+import Control.DeepSeq
+import GHC.Generics
+
+-- a locally focussed space
+data Space t = Space [t] t [t]
+  deriving (Generic, Generic1, Show)
+
+-- allowing strict evaluation of a space
+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)
+
+-- moving a space focus right
+right :: Space t -> Maybe (Space t)
+right (Space _ _ []) = Nothing
+right (Space l c (r:rs)) = Just $ Space (c:l) r rs
+
+-- moving a space's focus left
+left :: Space t -> Maybe (Space t)
+left (Space [] _ _) = Nothing
+left (Space (l:ls) c r) = Just $ Space ls l (c:r)
+
+-- iterate until we reach an edge
+finterate :: (a -> Maybe a) -> a -> [a]
+finterate f x = case (f x) of
+  Nothing -> []
+  Just y -> y : finterate f y
+
+-- our space is a comonad
+instance Comonad Space where
+  -- duplicate creats a meta space
+  duplicate w =
+    Space (finterate left w)
+          w
+          (finterate right w)
+  -- extract simply returns the focussed element
+  extract (Space _ c _) = c
+
+-- clamp an infinite space to a finite space
+-- relative to center
+clampRel :: Int -> Int -> Space t -> Space t
+clampRel x y (Space l m r) = Space (take x l) m (take y r)
+
+-- as above, but with a set width
+-- if the width is even, we need to take one less from the left
+clamp :: Int -> Space t -> Space t
+clamp w (Space l m r) = Space (take ln l) m (take h r)
+  where
+    h = w `div` 2
+    ln = h - (if even w then 1 else 0)
+
+-- materialises a space, will hang if infinite
+mat :: Space t -> [t]
+mat (Space l m r) = (reverse l) ++ (m:r)
+
+-- as above, but clamps to a given size first
+matn :: Int -> Space t -> [t]
+matn n = mat . (clamp n)
+
diff --git a/src/Spaces/Space2.hs b/src/Spaces/Space2.hs
new file mode 100644
index 0000000..4bdcd21
--- /dev/null
+++ b/src/Spaces/Space2.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Spaces.Space2 where
+
+import Comonad
+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)]
+  deriving (Generic, Generic1, Show)
+
+-- generating strict data instances
+instance NFData a => NFData (Space2 a)
+instance NFData1 Space2
+
+-- we can fmap into this structure by recursively fmapping
+-- the inner spaces
+instance Functor Space2 where
+  fmap f (Space2 u m d) =
+    Space2 (fmap (fmap f) u) (fmap f m) (fmap (fmap f) d)
+
+-- map a partial function, converting to non maybe values
+fintermap :: (a -> Maybe a) -> [a] -> [a]
+fintermap _ [] = []
+fintermap f (a:as) = case f a of
+  Nothing -> []
+  Just y -> y : fintermap f as
+
+f :: ((Space2 a) -> Maybe (Space2 a)) -> Space (Space2 a) -> Maybe (Space (Space2 a))
+f g (Space l m r) = case (g m) of
+  Nothing -> Nothing
+  Just y -> Just $ Space (fintermap g l) y (fintermap g r)
+
+-- 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
+  -- to extract we simply recursively extract
+  extract (Space2 _ m _) = extract m
+
+-- directional moving of focus
+up2 :: Space2 t -> Maybe (Space2 t)
+up2 (Space2 [] _ _) = Nothing
+up2 (Space2 (u:us) m d) = Just $ Space2 us u (m:d)
+
+down2 :: Space2 t -> Maybe (Space2 t)
+down2 (Space2 _ _ []) = Nothing
+down2 (Space2 u m (d:ds)) = Just $ Space2 (m:u) d ds
+
+noLeft :: Space t -> Bool
+noLeft (Space [] _ _) = True
+noLeft _ = False
+
+noRight :: Space t -> Bool
+noRight (Space _ _ []) = True
+noRight _ = False
+
+-- left and right require mapping further
+-- we are assuming things are rectangular (maybe a bad idea?)
+left2 :: Space2 t -> Maybe (Space2 t)
+left2 (Space2 u m d) =
+  if check
+    then Nothing
+    else Just $ Space2 (fmap (f . left) u) (f $ left m) (fmap (f . left) d)
+  where
+    check = noLeft m
+    f l = fromJust l
+
+right2 :: Space2 t -> Maybe (Space2 t)
+right2 (Space2 u m d) =
+  if check
+    then Nothing
+    else Just $ Space2 (fmap (f . right) u) (f $ right m) (fmap (f . right) d)
+  where
+    check = noRight m
+    f l = fromJust l
+
+-- clamp as we do in 1d Spaces
+clampRel2 :: Int -> Int -> Int -> Int -> Space2 t -> Space2 t
+clampRel2 w x y z (Space2 u m d) = Space2 (take w $ fmap f u) (f m) (take x $ fmap f d)
+  where
+    f = clampRel y z
+
+clamp2 :: Int -> Int -> Space2 t -> Space2 t
+clamp2 w h = clampRel2 nu nd nl nr
+  where
+    nu = h `div` 2
+    nd = nu - (if even h then 1 else 0)
+    nr = w `div` 2
+    nl = nr - (if even w then 1 else 0)
+
+mat2 :: Space2 t -> [[t]]
+mat2 (Space2 u m d) = (reverse (fmap mat u)) ++ ((mat m):(fmap mat d))
+
+matn2 :: Int -> Int -> Space2 t -> [[t]]
+matn2 w h = mat2 . (clamp2 w h)
+
+step :: Comonad w => (w t -> t) -> w t -> w t
+step f w = w =>> f