@@ -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 |
@@ -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; | |||
@@ -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 |
@@ -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) |
@@ -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 | |||
------------------- | |||
------------------- | |||
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 Space t = Space [t] t [t] | |||
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 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 :: 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 | |||
----------------------- | |||
----------------------- | |||
----------------- | |||
-- brick stuff -- | |||
----------------- | |||
data CellState = Alive | Dead | |||
deriving (Eq, Bounded, Enum) | |||
data Tick = Tick | |||
type Name = () | |||
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') | |||
-- App definition | |||
instance Show CellState | |||
where | |||
show Alive = "█" | |||
show Dead = " " | |||
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 | |||
} | |||
rule :: Space CellState -> CellState | |||
rule (Space (l:_) _ (r:_)) | |||
| l == r = Dead | |||
| otherwise = Alive | |||
-- Handling events | |||
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 | |||
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 | |||
takeGive :: Int -> [a] -> ([a],[a]) | |||
takeGive n as = ( (take n as), (drop n as) ) | |||
-------------------------- | |||
-------------------------- | |||
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 | |||
-------------- | |||
-------------- | |||
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 | |||
--runAutomata :: Space2 CellState -> Int -> Int -> IO () | |||
--runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s | |||
--runAutomata s n w = do | |||
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" |
@@ -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 |