|
- {-# 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
- 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
-
- -----------------
- -- 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 :: IO ()
- main = do
- options <- parseArgs
- let w = (optWidth options)
- let h = (optHeight options)
- 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
- 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"
|