Conway's game of life

README

main' に 初期状態を 与えればいい

lifegame.hs

import Data.Char (isSpace)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Control.Concurrent (threadDelay)

type Rule = U.Vector Bool -> Bool -> Bool
type Board = V.Vector (U.Vector Bool)

rule :: Rule
rule v b | U.length v == 8 = go b
  where
    count = U.length $ U.filter id v
    go False = count == 3
    go True  = count == 2 || count == 3
rule _ _ = error "number of neighborhoods must be 8"

makeBoard :: [String] -> [String]
makeBoard b = replicate 150 ' ' : replicate 15 ""
  ++ map (replicate 40 ' ' ++) b ++ replicate 20 ""

glider :: [String]
glider = makeBoard
  [ "###"
  , "#"
  , " #"
  ]

galaxy :: [String]
galaxy = f 4
  [ "###### ##"
  , "###### ##"
  , "       ##"
  , "##     ##"
  , "##     ##"
  , "##     ##"
  , "##       "
  , "## ######"
  , "## ######"
  ]
  where
    f n b = replicate n ""
      ++ map (\s -> replicate n ' ' ++ s ++ replicate n ' ') b
      ++ replicate n ""

infGrowth :: [String]
infGrowth = makeBoard ["######## #####   ###      ####### #####"]

neighborhood :: (Int,Int) -> Board -> U.Vector Bool
neighborhood (x,y) v = n
  where
    vl = V.length v
    v0 = v V.! ((y-1) `mod` vl)
    v0l = U.length v0
    v1 = v V.! y
    v1l = U.length v1
    v2 = v V.! ((y+1) `mod` vl)
    v2l = U.length v2
    n = U.fromList
      [ v0 U.! ((x-1) `mod` v0l), v0 U.! x, v0 U.! ((x+1) `mod` v0l)
      , v1 U.! ((x-1) `mod` v1l),           v1 U.! ((x+1) `mod` v1l)
      , v2 U.! ((x-1) `mod` v2l), v2 U.! x, v2 U.! ((x+1) `mod` v2l)
      ]

neighborhood' :: (Int,Int) -> Board -> U.Vector Bool
neighborhood' (x,y) v = n
  where
    f = maybe False id
    g = maybe U.empty id
    v0 = g $ v V.!? (y-1)
    v1 = v V.! y
    v2 = g $ v V.!? (y+1)
    n = U.fromList
      [ f $ v0 U.!? (x-1), f $ v0 U.!? x, f $ v0 U.!? (x+1)
      , f $ v1 U.!? (x-1),                f $ v1 U.!? (x+1)
      , f $ v2 U.!? (x-1), f $ v2 U.!? x, f $ v2 U.!? (x+1)
      ]

step :: Board -> Board
step v = bmap (\b x y -> rule (neighborhood (x,y) v) b) v
-- step v = bmap (\b x y -> rule (neighborhood' (x,y) v) b) v
  where
    bmap f = V.imap (\y row -> U.imap (\x b -> f b x y) row)

run :: Int -> Board -> V.Vector Board
run s v = V.iterateN s step v

beforeRun :: Board -> Board
beforeRun old = V.map fill v
  where
    v = if V.null old then V.singleton U.empty else old
    l = V.maximum $ V.map U.length v
    fill u
      | U.length u == l = u
      | otherwise = u U.++ U.generate (l - U.length u) (\_ -> False)

showBoard :: Board -> V.Vector String
showBoard = V.map showRow
  where
    showRow = U.toList . U.map (\b -> if b then '#' else ' ')

toBoard :: [String] -> Board
toBoard = V.map toRow . V.fromList
  where
    toRow = U.map (not . isSpace) . U.fromList

main' :: [String] -> IO ()
main' str = do
  putStr "\x1b[?25l"
  putStr "\x1b[2J"
  let ini = beforeRun $ toBoard str
  let border = do
        let width = U.length $ V.head ini
        putStr "+"
        putStr $ replicate width '-'
        putStrLn "+"
  let go v = do
        putStr "\x1b[f"
        border
        V.mapM_ (\s -> putStr "|" >> putStr s >> putStrLn "|") $ showBoard $! v
        border
        threadDelay $ 1000 * 250
        go (step v)
  go ini

main :: IO ()
main = main' galaxy