ライフゲームのシミュレーション

Main.hs

module Main where

import Graphics.Gloss

class Functor w => Comonad w where
  extract :: w a -> a
  extend :: (w b -> a) -> w b -> w a
  duplicate :: w a -> w (w a)

  duplicate = extend id
  extend f = fmap f . duplicate


data Z a = Z [a] a [a]

left, right :: Z a -> Z a
left (Z (l:ls) c rs) = Z ls l (c:rs)
right (Z ls c (r:rs)) = Z (c:ls) r rs


iterate1 :: (a -> a) -> a -> [a]
iterate1 f = tail . iterate f

instance Functor Z where
  fmap f (Z ls c rs) = Z (fmap f ls) (f c) (fmap f rs)

instance Comonad Z where
  extract (Z _ a _) = a
  duplicate z = Z (iterate1 left z) z (iterate1 right z)


newtype Z2 a = Z2 (Z (Z a))

instance Functor Z2 where
  fmap f (Z2 zz) = Z2 (fmap (fmap f) zz)

instance Comonad Z2 where
  extract (Z2 zz) = extract (extract zz)
  duplicate (Z2 zz) = fmap Z2 . Z2 . roll $ roll zz where
    roll :: Z (Z a) -> Z (Z (Z a))
    roll zz = Z (iterate1 (fmap left) zz) zz (iterate1 (fmap right) zz)


neighbours :: Z2 Bool -> Int
neighbours (Z2 (Z
  (Z (n0:_) n1 (n2: _):_)
  (Z (n3:_) _  (n4:_))
  (Z (n5:_) n6 (n7: _):_))) =
    length $ filter id [n0, n1, n2, n3, n4, n5, n6, n7]

life :: Z2 Bool -> Bool
life z = (a && (n == 2 || n == 3)) || (not a && n == 3)
  where
    a = extract z
    n = neighbours z


wWidth, wHeight :: Num a => a
wWidth = 640
wHeight = 480

type Model = Z2 Bool

draw :: Model -> Picture
draw (Z2 (Z _ _ rows)) =
  let cSize   = 20
      cell    = translate (-cSize / 2) (cSize / 2) $ rectangleSolid cSize cSize
      b2c b   = if b then black else white
      nWidth  = ceiling $ wWidth / cSize
      nHeight = ceiling $ wHeight / cSize
      cells   = do
        ((Z _ _ row), h) <- zip rows [1..nHeight]
        (b, w) <- zip row [1..nWidth]
        let x = fromIntegral w * cSize - wWidth / 2
            y = wHeight / 2 - fromIntegral h * cSize
            transform = color (b2c b) . translate x y
        pure $ transform cell
   in mconcat cells


toZ :: a -> [a] -> Z a
toZ a xs = Z (repeat a) a (xs ++ repeat a)

toZ2 :: a -> [[a]] -> Z2 a
toZ2 a xss = Z2 $ toZ (toZ a []) (map (toZ a) xss)


main :: IO ()
main = simulate inWindow white 3 initModel draw (\_ _ -> extend life)
  where
    inWindow  = InWindow "Haskell Day 2018" (wWidth, wHeight) (100, 100)
    field = [ " # "
            , "  #"
            , "###"
            ]
    initModel = toZ2 False $ map (map (== '#')) field