tA/cellularAutomata
2
0
Fork 1
Code Issues Pull Requests Releases Wiki Activity

clean up + easier rule generation

Browse Source
This commit is contained in:
Thorn Avery 2021-04-21 10:45:00 +12:00
parent 95808f5a9b
commit 68c7916fa4
7 changed files with 231 additions and 2509 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2320
conwayExample.txt
View File

File diff suppressed because it is too large Load Diff

92
src/Automata.hs
View File

@ -8,6 +8,7 @@ import Spaces.Space2
import System.Random
import GHC.Generics
import Control.DeepSeq
import Data.Maybe
-----------------------
-- cellular automata --
@ -59,32 +60,77 @@ instance Show CellState
-- | l == r = m
-- | otherwise = if m == Alive then Dead else Alive
------------------------
-- grabbing neighbors --
------------------------
-- we want to be able to create a list of (Maybe CellState)
-- representing each neighbor, this way it will work on the
-- edges, and also we can fix the position of ecah neighbor
-- so that rules can be directional also.
grabNeighbors :: Space2 CellState -> [(Maybe CellState)]
grabNeighbors s = let
tl = grabTopLeft s
t = grabTop s
tr = grabTopRight s
l = grabLeft s
r = grabRight s
bl = grabBotLeft s
b = grabBot s
br = grabBotRight s
in [tl, t, tr, l, r, bl, b, br]
grabTemplate :: (Space2 CellState -> Maybe (Space2 CellState))
-> Space2 CellState -> Maybe CellState
grabTemplate f s = case f s of
Nothing -> Nothing
Just x -> Just $ extract x
grabTop, grabBot, grabLeft, grabRight :: Space2 CellState -> Maybe CellState
grabTop = grabTemplate up2
grabBot = grabTemplate down2
grabLeft = grabTemplate left2
grabRight = grabTemplate right2
maycom :: (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a
maycom f g s = do
x <- f s
y <- g x
return y
grabTopLeft, grabTopRight, grabBotLeft, grabBotRight :: Space2 CellState -> Maybe CellState
grabTopLeft = grabTemplate (maycom up2 left2)
grabTopRight = grabTemplate (maycom up2 right2)
grabBotLeft = grabTemplate (maycom down2 left2)
grabBotRight = grabTemplate (maycom down2 right2)
filtJust :: [(Maybe a)] -> [a]
filtJust [] = []
filtJust (Nothing:as) = filtJust as
filtJust ((Just a):as) = a:(filtJust as)
numMatch :: CellState -> [(Maybe CellState)] -> Int
numMatch c = length . (filter (== c)) . filtJust
--------------
-- 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
conway :: Space2 CellState -> CellState
conway s = case extract s of
Rock -> Paper
Paper -> if numSci == 3 then Scissors else Paper
Scissors -> if numSci == 2 || numSci == 3 then Scissors else Paper
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
numSci = numMatch Scissors ns
ns = grabNeighbors s
--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
rps :: Space2 CellState -> CellState
rps s
= case extract s of
Rock -> if (numNs Paper) > 2 then Paper else Rock
Paper -> if (numNs Scissors) > 2 then Scissors else Paper
Scissors -> if (numNs Rock) > 2 then Rock else Scissors
where
numNs c = numMatch c $ grabNeighbors s

70
src/BrickStuff.hs Normal file
View File

@ -0,0 +1,70 @@
{-# LANGUAGE OverloadedStrings #-}
module BrickStuff where
import Automata
import Spaces.Space2
import System.Random
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
-----------------
-- brick stuff --
-----------------
data Tick = Tick
type Name = ()
-- App definition
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
}
-- Handling events
theMap :: AttrMap
theMap = attrMap V.defAttr
[ (rockAttr, V.red `on` V.blue)
, (scissorsAttr, V.green `on` V.red)
, (paperAttr, V.blue `on` V.green)
]
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
bw = mat2 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"
initGame :: IO (Space2 CellState)
initGame = do
rng <- getStdGen
return $ createRandSpace2 rng

169
src/Main.hs
View File

@ -1,129 +1,18 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad
import System.Process
import System.Random
import System.Console.GetOpt
import System.Environment(getArgs, getProgName)
import Data.Maybe (fromMaybe)
import Comonad
import Spaces.Space2
import Spaces.Space1
import Automata
import BrickStuff
import Options
import Spaces.Space2
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 Brick.BChan
import Control.Monad
import Control.Applicative
import Control.Monad.IO.Class
import Control.Concurrent
import Control.DeepSeq
-----------------
-- brick stuff --
-----------------
data Tick = Tick
type Name = ()
-- App definition
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
}
-- Handling events
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 --
---------------
-- takes a generator and returns
-- an infinite list of bools
ilobs :: StdGen -> [Bool]
ilobs rng = b : (ilobs r)
where
(b,r) = random rng
-----------------
-- gross io bs --
-----------------
-- everything below this line deals with
-- input/output, and is therefore gross
-- i will clean this up one day, but it
-- hurts my soul.
------------------------
-- command line flags --
------------------------
-- structure containing the programs options
data Options = Options
{ optWidth :: Int
, optGenerations :: Int
, optHeight :: Int
} deriving Show
-- the default options for the program
-- the width and generations are injected
-- and intended to be gotten at runtime
-- to match the window dimensions
defaultOptions :: Int -> Int -> Options
defaultOptions w h = Options
{ optWidth = w
, optGenerations = 40
, optHeight = h
}
-- the avaliable options
options :: [OptDescr (Options -> Options)]
options =
[ Option ['w'] ["width"]
(ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
"term width"
, Option ['g'] ["generations"]
(ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS")
"time steps to simulate"
, Option ['h'] ["height"]
(ReqArg (\t opts -> opts { optHeight = (read t) }) "HEIGHT")
"term height"
]
-- parse the options into the structure
-- erroring if encountering a flag not known to us
parseArgs :: IO Options
parseArgs = do
argv <- getArgs
progName <- getProgName
tw <- readProcess "tput" [ "cols" ] ""
th <- readProcess "tput" [ "lines" ] ""
case getOpt RequireOrder options argv of
(opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
(_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
where
header = "Usage: " ++ progName ++ " [OPTION...]"
helpMessage = usageInfo header options
initGame :: IO (Space2 CellState)
initGame = do
rng <- getStdGen
return $ createRandSpace2 rng
import qualified Graphics.Vty as V
---------------
-- main loop --
@ -137,51 +26,9 @@ main = do
chan <- newBChan 1
forkIO $ forever $ do
writeBChan chan Tick
threadDelay 100000
threadDelay 70000
g <- initGame
let buildVty = V.mkVty V.defaultConfig
initialVty <- buildVty
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
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
bw = mat2 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"
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

56
src/Options.hs Normal file
View File

@ -0,0 +1,56 @@
module Options where
import System.Environment
import System.Console.GetOpt
import System.Process
------------------------
-- command line flags --
------------------------
-- structure containing the programs options
data Options = Options
{ optWidth :: Int
, optGenerations :: Int
, optHeight :: Int
} deriving Show
-- the default options for the program
-- the width and generations are injected
-- and intended to be gotten at runtime
-- to match the window dimensions
defaultOptions :: Int -> Int -> Options
defaultOptions w h = Options
{ optWidth = w
, optGenerations = 40
, optHeight = h
}
-- the avaliable options
options :: [OptDescr (Options -> Options)]
options =
[ Option ['w'] ["width"]
(ReqArg (\w opts -> opts { optWidth = (read w) }) "WIDTH")
"term width"
, Option ['g'] ["generations"]
(ReqArg (\t opts -> opts { optGenerations = (read t) }) "GENERATIONS")
"time steps to simulate"
, Option ['h'] ["height"]
(ReqArg (\t opts -> opts { optHeight = (read t) }) "HEIGHT")
"term height"
]
-- parse the options into the structure
-- erroring if encountering a flag not known to us
parseArgs :: IO Options
parseArgs = do
argv <- getArgs
progName <- getProgName
tw <- readProcess "tput" [ "cols" ] ""
th <- readProcess "tput" [ "lines" ] ""
case getOpt RequireOrder options argv of
(opts, [], []) -> return (foldl (flip id) (defaultOptions (read tw) (read th)) opts)
(_, _, errs) -> ioError (userError (concat errs ++ helpMessage))
where
header = "Usage: " ++ progName ++ " [OPTION...]"
helpMessage = usageInfo header options

11
src/Spaces/Space1.hs
View File

@ -3,6 +3,8 @@
module Spaces.Space1 where
import Comonad
import System.Random
import Control.DeepSeq
import GHC.Generics
@ -65,3 +67,12 @@ mat (Space l m r) = (reverse l) ++ (m:r)
matn :: Int -> Space t -> [t]
matn n = mat . (clamp n)
-- create a randomly filled space
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

22
src/Spaces/Space2.hs
View File

@ -3,10 +3,12 @@
module Spaces.Space2 where
import Comonad
import Spaces.Space1
import System.Random
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)]
@ -36,16 +38,16 @@ f g (Space l m r) = case (g m) of
-- 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
duplicate w =
Space2 (finterate (f up2) dm) dm (finterate (f down2) dm)
where
dm = Space (finterate left2 w) w (finterate right2 w)
-- to extract we simply recursively extract
extract (Space2 _ m _) = extract m
@ -108,3 +110,13 @@ matn2 w h = mat2 . (clamp2 w h)
step :: Comonad w => (w t -> t) -> w t -> w t
step f w = w =>> f
-- create a randomly filled space
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