@@ -3,7 +3,8 @@ | |||||
module Automata where | module Automata where | ||||
import Comonad | import Comonad | ||||
import Spaces | |||||
import Spaces.Space1 | |||||
import Spaces.Space2 | |||||
import System.Random | import System.Random | ||||
import GHC.Generics | import GHC.Generics | ||||
import Control.DeepSeq | import Control.DeepSeq | ||||
@@ -9,7 +9,8 @@ import System.Console.GetOpt | |||||
import System.Environment(getArgs, getProgName) | import System.Environment(getArgs, getProgName) | ||||
import Data.Maybe (fromMaybe) | import Data.Maybe (fromMaybe) | ||||
import Comonad | import Comonad | ||||
import Spaces | |||||
import Spaces.Space2 | |||||
import Spaces.Space1 | |||||
import Automata | import Automata | ||||
import Brick | import Brick | ||||
import Brick.BChan (newBChan, writeBChan) | import Brick.BChan (newBChan, writeBChan) | ||||
@@ -140,7 +141,7 @@ main = do | |||||
g <- initGame | g <- initGame | ||||
let buildVty = V.mkVty V.defaultConfig | let buildVty = V.mkVty V.defaultConfig | ||||
initialVty <- buildVty | 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 :: (Space2 CellState) -> BrickEvent Name Tick -> EventM Name (Next (Space2 CellState)) | ||||
handleEvent g (AppEvent Tick) = continue $ step rps g | 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 :: Int -> Int -> Space2 CellState -> Widget Name | ||||
drawGrid h w g = vBox rows | drawGrid h w g = vBox rows | ||||
where | where | ||||
bw = bound2cw w h g | |||||
bw = mat2 g | |||||
rows = [ hBox $ cellsInRow r | r <- bw ] | rows = [ hBox $ cellsInRow r | r <- bw ] | ||||
cellsInRow y = map drawCell y | cellsInRow y = map drawCell y | ||||
@@ -166,3 +167,21 @@ rockAttr, scissorsAttr, paperAttr :: AttrName | |||||
rockAttr = "rockAttr" | rockAttr = "rockAttr" | ||||
paperAttr = "paperAttr" | paperAttr = "paperAttr" | ||||
scissorsAttr = "scissorsAttr" | 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 |
@@ -1,176 +0,0 @@ | |||||
{-# LANGUAGE BangPatterns #-} | |||||
{-# LANGUAGE DeriveGeneric #-} | |||||
module Spaces where | |||||
import Comonad | |||||
import System.Random | |||||
import Control.DeepSeq | |||||
import GHC.Generics | |||||
------------ | |||||
------------ | |||||
data Space t = Space [t] t [t] | |||||
deriving (Generic, Generic1) | |||||
instance NFData a => NFData (Space a) | |||||
instance NFData1 Space | |||||
instance Functor Space where | |||||
fmap f (Space l c r) = Space (map f l) (f c) (map f r) | |||||
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 | |||||
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 :: Int -> Int -> Space t -> [t] | |||||
bound i j (Space l c r) = (reverse (take i l)) ++ (c:(take j r)) | |||||
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 | |||||
--------------- | |||||
--------------- | |||||
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) | |||||
step :: Comonad w => (w t -> t) -> w t -> w t | |||||
step f w = w =>> f | |||||
------------------- | |||||
------------------- | |||||
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 |
@@ -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) | |||||
@@ -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 |