From bdda683c42815b3992f6f4b313bcdf44fe07fff3 Mon Sep 17 00:00:00 2001 From: Thorn Avery 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