@@ -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 | |||
@@ -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 |
@@ -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 |