Conway's Game of Life

Main.hs

import FreeGame
import qualified Data.IntMap as IM
import Control.Monad.State.Strict
import Control.Arrow

data Cells a = Cells (IM.IntMap a) (Int,Int)
instance Functor Cells where
  fmap f (Cells m k) = Cells (fmap f m) k

type Board = Cells Bool

gridW :: Int
gridW = 40

rule :: Int -> Bool -> Bool
rule n False
  | n == 3 = True
  | otherwise = False
rule n True
  | 2 <= n && n <= 3 = True
  | otherwise = False

def :: Int -> Int -> Board
def w h = 
  Cells
    (IM.fromList [(x*w+y,False)|x<-[0..w-1], y<-[0..h-1]])              
    (w,h)

-- Cellはトーラスとして考える
(!?) :: Cells a -> (Int,Int) -> Maybe a
Cells m (w,h) !? (x,y) = case IM.member n m of
  True -> Just $ m IM.! n
  False -> Nothing
  where
    (x',y') = (x `mod` w, y `mod` h)
    n = x'*w+y'

paintGrid :: Game ()
paintGrid = do
  let c = Color 1 1 1 0.4

  forM_ [0..640 `div` gridW] $ \i -> do
    thickness 2.0 $ color c $ line $
      [V2 (fromIntegral $ i*gridW) 0
      ,V2 (fromIntegral $ i*gridW) 480]
  
  forM_ [0..480 `div` gridW] $ \i -> do
    thickness 2.0 $ color c $ line $
      [V2   0 (fromIntegral $ i*gridW)
      ,V2 640 (fromIntegral $ i*gridW)]

paintBoard :: Board -> Game ()
paintBoard b@(Cells _ (w,h)) = mapM_ go [(b !? (x,y), (x,y))|x<-[0..w-1], y<-[0..h-1]]
  where
    go :: (Maybe Bool, (Int,Int)) -> Game ()
    go (Just True, (bx,by)) = do
      color white $ polygon $ fmap (fmap (fromIntegral . (gridW*))) $ [V2 bx by, V2 (bx+1) by, V2 (bx+1) (by+1), V2 bx (by+1)]
    go (Just False, _) = return ()
    go (Nothing, _) = error "out of range:Board"

updateBoard :: Board -> Board
updateBoard b@(Cells m s@(w,_)) = Cells (IM.mapWithKey (\n -> go (divMod n w)) m) s
  where
    go :: (Int,Int) -> Bool -> Bool
    go (x,y) k = flip rule k $ length $ filter (== Just True) $ fmap (b!?) $
      [(x-1,y-1), (x,y-1), (x+1,y-1),
       (x-1,y  ),          (x+1,y  ),
       (x-1,y+1), (x,y+1), (x+1,y+1)]

mouseOver :: (Int,Int) -> Game ()
mouseOver (bx,by) = let c = Color 1 1 1 0.4 in
  color c $ polygon $ fmap (fmap (fromIntegral . (gridW*))) $ [V2 bx by, V2 (bx+1) by, V2 (bx+1) (by+1), V2 bx (by+1)]

main = do
  runGameDefault $ do
    setTitle "Conway's Game of Life"
    clearColor $ Color 0 0 0.2 1
    execStateT mainloop (False, def (640 `div` gridW) (480 `div` gridW))
  return ()

  where
    mainloop :: StateT (Bool,Board) Game ()
    mainloop = do
      (running, b) <- get
      lift $ paintBoard $ b
      lift $ paintGrid
      tick
      lift mouseUpL >>= toggleByMouse

      fmap (flip div gridW . floor) `fmap` lift mousePosition
        >>= \(V2 x y) -> lift $ mouseOver (x,y)

      when running $ do
        modify $ second $ updateBoard

      (keyDown $ charToKey 'Z') >>= \m -> do
        when m $ modify $ first $ const True
      (keyDown $ charToKey 'X') >>= \m -> do
        when m $ modify $ first $ const False
      (keyDown $ charToKey 'C') >>= \m -> do
        when m $ modify $ second $ fmap (const False)
      (keyDown $ KeyRight) >>= \m -> do
        when m $ do
          modify $ second $ updateBoard
          modify $ first $ const False

      (keyPress $ KeyEscape) >>= \m -> do
        unless m $ mainloop

    toggleByMouse :: Bool -> StateT (Bool, Board) Game ()
    toggleByMouse False = return ()
    toggleByMouse True = do
      V2 x y <- fmap floor `fmap` lift mousePosition
      modify $ second $ toggle (x `div` gridW, y `div` gridW)

      where
        toggle :: (Int,Int) -> Board -> Board
        toggle (x,y) (Cells m s@(w,_)) =
          Cells (IM.adjust go (x*w+y) m) s

        go True = False
        go False = True