cellularAutomata/src/Main.hs

module Main where

--import System.Random
import Control.Monad
import System.Process
import System.Random
import System.Console.GetOpt
import System.Environment(getArgs, getProgName)
import Data.Maybe (fromMaybe)

-------------------
-- 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 --
-----------------------

-- 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

-- 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 = " "

-- a rule stating how a cell is determined
rule :: Space CellState -> CellState
rule (Space (l:_) _ (r:_))
  | l == r = Dead
  | otherwise = Alive

-- take a space and a rule and
-- return the next space
step :: (Space t -> t) -> Space t -> Space t
step f w = w =>> f

---------------
-- 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
  } 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 = 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"
  ]

-- 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

---------------
-- main loop --
---------------

-- simply print the current space, then recurse to the next
runAutomata :: Space CellState -> Int -> Int -> IO ()
runAutomata s 0 w = putStrLn $ concat $ map show $ boundw w s
runAutomata s n w = do
  putStrLn $ concat $ map show $ boundw w s
  runAutomata (step rule 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 = (optGenerations options)
  let wh = (w + 1) `div` 2
  let m = head cs
  let l = take wh $ drop 1 cs
  let r = take wh $ drop wh $ drop 1 cs
  let s = Space (l ++ (repeat Dead)) m (r ++ (repeat Dead))
  runAutomata s h w