cells.hs

import System.Random
import System.Exit

import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game
import qualified Graphics.Gloss.Interface.IO.Game as G
import qualified Control.Monad
import Data.List ( zipWith4 )

windowWidth = 800
windowHeight = 600

rows = 10
cols = 10

cellWidth = windowWidth `div` cols
cellHeight = windowHeight `div` rows

window = InWindow "1D Cellular Automata Explorer" (windowWidth, windowHeight) (0, 0)
background = white
fps = 1

type Cell = Bool
type Row = [Cell]
type Grid = [Row]

--- treat three bools as bits of an int
lookupRuleIndex :: Bool -> Bool -> Bool -> Int
lookupRuleIndex a b c =
    let
        a' = if a then 1 else 0
        b' = if b then 2 else 0
        c' = if c then 4 else 0
    in
        a' + b' + c'

--- convert 8-bit int to 8 bools
ruleToBools :: Integral uInt8 => uInt8 -> [Bool]
ruleToBools n =
    let
        a = n `mod` 2 == 1
        b = n `div` 2 `mod` 2 == 1
        c = n `div` 4 `mod` 2 == 1
        d = n `div` 8 `mod` 2 == 1
        e = n `div` 16 `mod` 2 == 1
        f = n `div` 32 `mod` 2 == 1
        g = n `div` 64 `mod` 2 == 1
        h = n `div` 128 `mod` 2 == 1
    in
        [a, b, c, d, e, f, g, h]

type RuleFunction = (Bool -> Bool -> Bool -> Bool)

--- for given rule number, return function taking three bools and returning one bool
ruleToFunction :: Integral uInt8 => uInt8 -> RuleFunction
ruleToFunction n =
    let
        bools = ruleToBools n
    in
        \a b c -> bools !! lookupRuleIndex a b c

--- map a RuleFunction over a Row three Cells at a time
mapRule :: RuleFunction -> Row -> Row
mapRule f row =
    let
        (a:b:c:rest) = row
    in
        f a b c : mapRule f rest

--- append a Row to a Grid, ensuring there are only `rows` rows
appendRow :: Grid -> Row -> Grid
appendRow grid row =
    let
        (first:rest) = grid
        newGrid = rest ++ [row]
    in
        if length newGrid == rows
        then newGrid
        else first : newGrid

-- update the world
updateWorld :: Float -> World -> World
updateWorld _ (World grid rule) =
    let
        -- produce new row from last row
        newRow = mapRule rule (last grid)
        -- append new row to grid
        newGrid = appendRow grid newRow
    in
        World newGrid rule

mkEmptyGrid rows cols = replicate rows (replicate cols False)

-- Create row of length n with a single centered cell set to True
mkCenteredRow :: Int -> Row
mkCenteredRow n =
    let n2 = n `div` 2
    in replicate n2 False ++ [True] ++ replicate (n2 - 1) False

defaultGrid = [mkCenteredRow cols]

-- Draw a cell at the given position
drawCell :: Int -> Int -> Picture
drawCell x y =
    let ox = fromIntegral (x * cellWidth) :: Float
        oy = fromIntegral (y * cellHeight) :: Float
        w = fromIntegral cellWidth
        h = fromIntegral cellHeight
    in translate ox oy
     $ rectangleSolid w h

-- Draw a row for the given index
drawRow :: Int -> Row -> Picture
drawRow i row =
    let
        y = i * cellHeight
        xs = map (`drawCell` y) [0..length row - 1]
    in
        pictures xs

-- Draw a Grid
drawGrid :: Grid -> Picture
drawGrid grid =
    let
        is = [0..length grid - 1]
        rows = map (grid !!) is
        tups = zip is rows
    in
        pictures $ map (uncurry drawRow) tups

data World = World {
    grid :: Grid,
    rule :: RuleFunction
}

--- handle escape and quit
handleEvent :: Event -> a -> IO a
handleEvent (G.EventKey (G.SpecialKey G.KeyEsc) G.Down _ _) _ = exitSuccess
handleEvent _ c = return c

-- draw the grid after clearing the screen
draw :: World -> IO Picture
draw (World grid rule) =
    return $ pictures [drawGrid grid]

-- update the grid
update :: Monad m => Float -> World -> m World
update t (World grid rule) =
    return $ updateWorld t (World grid rule)

main :: IO ()
main =
    let
        rule = ruleToFunction 42
        world = World defaultGrid rule
    in playIO
        window
        background
        fps
        world
        draw
        handleEvent
        update