@@ -8,6 +8,7 @@ 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 -- | ||||
@@ -59,32 +60,77 @@ 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 (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 | |||||
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 | 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:_)) | |||||
numNs c = numMatch c $ grabNeighbors s |
@@ -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 |
@@ -1,129 +1,18 @@ | |||||
{-# LANGUAGE OverloadedStrings #-} | |||||
module Main where | 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 Comonad | ||||
import Spaces.Space2 | |||||
import Spaces.Space1 | |||||
import Automata | import Automata | ||||
import BrickStuff | |||||
import Options | |||||
import Spaces.Space2 | |||||
import Brick | 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.Applicative | ||||
import Control.Monad.IO.Class | import Control.Monad.IO.Class | ||||
import Control.Concurrent | import Control.Concurrent | ||||
import Control.DeepSeq | |||||
----------------- | |||||
----------------- | |||||
data Tick = Tick | |||||
type Name = () | |||||
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 | |||||
} | |||||
theMap :: AttrMap | |||||
theMap = attrMap V.defAttr | |||||
[ (rockAttr, V.red `on` V.blue) | |||||
, (scissorsAttr, V.green `on` V.red) | |||||
, (paperAttr, V.blue `on` V.green) | |||||
] | |||||
--------------- | |||||
--------------- | |||||
ilobs :: StdGen -> [Bool] | |||||
ilobs rng = b : (ilobs r) | |||||
where | |||||
(b,r) = random rng | |||||
----------------- | |||||
----------------- | |||||
------------------------ | |||||
------------------------ | |||||
data Options = Options | |||||
{ optWidth :: Int | |||||
, optGenerations :: Int | |||||
, optHeight :: Int | |||||
} deriving Show | |||||
defaultOptions :: Int -> Int -> Options | |||||
defaultOptions w h = Options | |||||
{ optWidth = w | |||||
, optGenerations = 40 | |||||
, optHeight = h | |||||
} | |||||
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" | |||||
] | |||||
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 -- | -- main loop -- | ||||
@@ -137,51 +26,9 @@ main = do | |||||
chan <- newBChan 1 | chan <- newBChan 1 | ||||
forkIO $ forever $ do | forkIO $ forever $ do | ||||
writeBChan chan Tick | writeBChan chan Tick | ||||
threadDelay 100000 | |||||
threadDelay 70000 | |||||
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 |
@@ -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 |
@@ -3,6 +3,8 @@ | |||||
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 | ||||
@@ -65,3 +67,12 @@ 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 |
@@ -3,10 +3,12 @@ | |||||
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)] | ||||
@@ -36,16 +38,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 | ||||
@@ -108,3 +110,13 @@ 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 |