diff --git a/cellularAutomata.cabal b/cellularAutomata.cabal index 5e84036..eeb7cdb 100644 --- a/cellularAutomata.cabal +++ b/cellularAutomata.cabal @@ -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 diff --git a/nix/cellularAutomata.nix b/nix/cellularAutomata.nix index bfa6576..6a91002 100644 --- a/nix/cellularAutomata.nix +++ b/nix/cellularAutomata.nix @@ -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; diff --git a/src/Automata.hs b/src/Automata.hs new file mode 100644 index 0000000..6d22f9a --- /dev/null +++ b/src/Automata.hs @@ -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 diff --git a/src/Comonad.hs b/src/Comonad.hs new file mode 100644 index 0000000..746bfca --- /dev/null +++ b/src/Comonad.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs index 1d2d2ce..17a52a8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 -------------------- --- 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) - ------------- --- spaces -- ------------- - --- a locally focussed space -data Space t = Space [t] t [t] - --- 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 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 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 - ------------------------ --- cellular automata -- ------------------------ +----------------- +-- brick stuff -- +----------------- --- the states our cells can be in --- may need to provide an ordering --- may need to generalise the number --- of states -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 --- how the states are displayed on screen --- this should probably be input to a function --- rather than hardcoded -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 + } --- a rule stating how a cell is determined -rule :: Space CellState -> CellState -rule (Space (l:_) _ (r:_)) - | l == r = Dead - | otherwise = Alive +-- Handling events --- 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 - --- 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 +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 --- this is kinda gross but if it works it works -takeGive :: Int -> [a] -> ([a],[a]) -takeGive n as = ( (take n as), (drop n as) ) - --------------------------- --- 2d cellular automata -- --------------------------- - -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 - --------------- --- 2d rules -- --------------- - -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 - --- simply print the current space, then recurse to the next ---runAutomata :: Space2 CellState -> Int -> Int -> IO () ---runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s ---runAutomata s n w = do --- mapM_ putStrLn $ map show $ concat $ bound2w w s --- runAutomata (step conway s) (n - 1) w - 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" diff --git a/src/Spaces.hs b/src/Spaces.hs new file mode 100644 index 0000000..b6825c7 --- /dev/null +++ b/src/Spaces.hs @@ -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