Compare commits

..

No commits in common. "master" and "master" have entirely different histories.

9 changed files with 2518 additions and 245 deletions

2
.gitignore vendored
View File

@ -1,4 +1,4 @@
result result
result-doc result-doc
*.swp *.swp
*.prof

2320
conwayExample.txt Normal file

File diff suppressed because it is too large Load Diff

View File

@ -2,11 +2,11 @@
"nodes": { "nodes": {
"flake-utils": { "flake-utils": {
"locked": { "locked": {
"lastModified": 1618868421, "lastModified": 1601282935,
"narHash": "sha256-vyoJhLV6cJ8/tWz+l9HZLIkb9Rd9esE7p+0RL6zDR6Y=", "narHash": "sha256-WQAFV6sGGQxrRs3a+/Yj9xUYvhTpukQJIcMbIi7LCJ4=",
"owner": "numtide", "owner": "numtide",
"repo": "flake-utils", "repo": "flake-utils",
"rev": "eed214942bcfb3a8cc09eb3b28ca7d7221e44a94", "rev": "588973065fce51f4763287f0fda87a174d78bf48",
"type": "github" "type": "github"
}, },
"original": { "original": {
@ -17,11 +17,11 @@
}, },
"nixpkgs": { "nixpkgs": {
"locked": { "locked": {
"lastModified": 1618942778, "lastModified": 1604368813,
"narHash": "sha256-k4zWLjNokLjhHT79RpmlFjQ7r0a1jc2BM62Jvgd0bF4=", "narHash": "sha256-UOLaURSO448k+4bGJlaSMYeo2F5F6CuFo9VoYDkhmsk=",
"owner": "NixOS", "owner": "NixOS",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "17a28909d4e8f8568b2640b6dcdff85cf372c6df", "rev": "d105075a1fd870b1d1617a6008cb38b443e65433",
"type": "github" "type": "github"
}, },
"original": { "original": {

View File

@ -8,7 +8,6 @@ import Spaces.Space2
import System.Random import System.Random
import GHC.Generics import GHC.Generics
import Control.DeepSeq import Control.DeepSeq
import Data.Maybe
----------------------- -----------------------
-- cellular automata -- -- cellular automata --
@ -60,77 +59,32 @@ instance Show CellState
-- | l == r = m -- | l == r = m
-- | otherwise = if m == Alive then Dead else Alive -- | 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 -- -- 2d rules --
-------------- --------------
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
numSci = numMatch Scissors ns
ns = grabNeighbors s
rps :: Space2 CellState -> CellState rps :: Space2 CellState -> CellState
rps s rps (Space2 u m d)
= case extract s of = case me of
Rock -> if (numNs Paper) > 2 then Paper else Rock Rock -> if (length $ filter (== Paper) ns) > 2 then Paper else Rock
Paper -> if (numNs Scissors) > 2 then Scissors else Paper Paper -> if (length $ filter (== Scissors) ns) > 2 then Scissors else Paper
Scissors -> if (numNs Rock) > 2 then Rock else Scissors Scissors -> if (length $ filter (== Rock) ns) > 2 then Rock else Scissors
where where
numNs c = numMatch c $ grabNeighbors s 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

View File

@ -1,70 +0,0 @@
{-# 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

View File

@ -1,18 +1,129 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Comonad
import Automata
import BrickStuff
import Options
import Spaces.Space2
import Brick
import Brick.BChan
import Control.Monad 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 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.Applicative
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Concurrent import Control.Concurrent
import qualified Graphics.Vty as V 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
--------------- ---------------
-- main loop -- -- main loop --
@ -26,9 +137,51 @@ main = do
chan <- newBChan 1 chan <- newBChan 1
forkIO $ forever $ do forkIO $ forever $ do
writeBChan chan Tick writeBChan chan Tick
threadDelay $ (optTime options) * 10000 threadDelay 100000
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) (clamp2 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
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

View File

@ -1,61 +0,0 @@
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
, optTime :: 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
, optTime = 7
}
-- 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"
, Option ['t'] ["time"]
(ReqArg (\t opts -> opts { optTime = (read t) }) "TIME")
"delay time"
]
-- 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

View File

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

View File

@ -3,12 +3,10 @@
module Spaces.Space2 where module Spaces.Space2 where
import Comonad import Comonad
import Spaces.Space1
import System.Random
import Data.Maybe import Data.Maybe
import Control.DeepSeq import Control.DeepSeq
import GHC.Generics import GHC.Generics
import Spaces.Space1
-- a nested space -- a nested space
data Space2 t = Space2 [(Space t)] (Space t) [(Space t)] data Space2 t = Space2 [(Space t)] (Space t) [(Space t)]
@ -38,16 +36,16 @@ f g (Space l m r) = case (g m) of
-- comonad instance for our 2d space -- comonad instance for our 2d space
instance Comonad Space2 where 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 -- to duplicate we must recursively duplicate in all directions
-- the focussed space becomes the whole space, with left and right -- the focussed space becomes the whole space, with left and right
-- mapped to each side. -- mapped to each side.
-- to do the up and down lists, each needs to be the middle space -- to do the up and down lists, each needs to be the middle space
-- mapped up and down as far as we can. -- mapped up and down as far as we can.
-- up2 and down2 will return Nothing when they cant go further -- 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 -- to extract we simply recursively extract
extract (Space2 _ m _) = extract m extract (Space2 _ m _) = extract m
@ -110,13 +108,3 @@ matn2 w h = mat2 . (clamp2 w h)
step :: Comonad w => (w t -> t) -> w t -> w t step :: Comonad w => (w t -> t) -> w t -> w t
step f w = w =>> f 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