はじめに

今回のリポジトリ

PureScriptでコンソール用のライフゲーム(Conway's Game of Life)を作りました。こんな感じです↓

PureScriptでコンソールライフゲーム① pic.twitter.com/8OS1OTtp72
— まとるる (@_matoruru) August 8, 2019

PureScriptでコンソールライフゲーム② pic.twitter.com/pfaSBlLPGX
— まとるる (@_matoruru) August 8, 2019

PureScriptでコンソールライフゲーム③ pic.twitter.com/benEgFT1BC
— まとるる (@_matoruru) August 8, 2019

使用するパッケージ

purescript-arrays
purescript-jstimers

作り方

ルールを定義する

以下のルールに従います。

誕生
あるセルが死んでいる場合、そのセルの周囲の生存セルがちょうど3つなら次の世代で誕生する。
生存
あるセルが生きている場合、そのセルの周囲の生存セルがちょうど2つまたは3つなら次の世代でも生存する。
過疎
あるセルが生きている場合、そのセルの周囲の生存セルが1つ以下なら次の世代では過疎で死亡する。
過密
あるセルが生きている場合、そのセルの周囲の生存セルが4以上なら次の世代では過密で死亡する。

type FieldSize
  = { w :: Int
    , h :: Int
    }

type Pos = Tuple Int Int

type Pattern = Array Pos

nextGen :: FieldSize -> Pattern -> Pattern
nextGen fs lives = concat >>> nubEq $ [ keeps, births ]
  where
    keeps  = filter (score fs lives >>> (==) 2) lives
    births = filter (score fs lives >>> (==) 3) $ map (neighbors fs) >>> concat $ lives

score :: FieldSize -> Pattern -> Pos -> Int
score fs lives = neighbors fs >>> intersect lives >>> length

neighbors :: FieldSize -> Pos -> Pattern
neighbors fs (Tuple x y) = [ Tuple (x-1) (y-1), Tuple x (y-1), Tuple (x+1) (y-1)
                           , Tuple (x-1) (y  ),                Tuple (x+1) (y  )
                           , Tuple (x-1) (y+1), Tuple x (y+1), Tuple (x+1) (y+1)
                           ] # map (wrap fs)

wrap :: FieldSize -> Pos -> Pos
wrap fs (Tuple x y) = Tuple (x `mod` fs.w) (y `mod` fs.h)

現在の状態に適用することで次の世代の状態を得る関数nextGenを作りました。wrap関数はフィールドの端と端を繋げるための関数です。score関数はそのセルの周囲の生存セルを数える関数です。

nextGen関数ではkeeps関数(次世代の生存セルのリスト)とbirths関数(次世代の誕生セルのリスト)を結合(concat)し、重複を排除(nubEq)しています。

パターンを移動させる

パターンを動かすためには、そのパターンを構成するセルを全て動かす必要があります。

※具体的なパターンは後ほど用意します。

move :: Int -> Int -> Pattern -> Pattern
move x y = map (_ + Tuple x y)

次は描画処理に入っていきます。

コンソール上のセルを描画する

data Readline

foreign import readline :: Effect Readline

foreign import consoleClear :: Effect Unit

foreign import cursorToImpl :: EffectFn3 Readline Int Int Unit

cursorTo :: Readline -> Int -> Int -> Effect Unit
cursorTo = runEffectFn3 cursorToImpl

foreign import logImpl :: EffectFn1 String Unit

log' :: String -> Effect Unit
log' = runEffectFn1 logImpl

logTo :: Readline -> Pos -> String -> Effect Unit
logTo rl (Tuple x y) c = cursorTo rl x y *> log' c

foreign import getRows :: Effect Int

foreign import getColumns :: Effect Int

data Color = Black | Green | Red | Blue

type Diff
  = { dead      :: Pattern
    , alive     :: Pattern
    , willDead  :: Pattern
    , willAlive :: Pattern
    }

replace :: Readline -> Diff -> Effect Unit
replace rl d = do
  foreachE d.dead      <<< flip logTo' $ color Black "□"
  foreachE d.alive     <<< flip logTo' $ color Green "■"
  foreachE d.willDead  <<< flip logTo' $ color Red   "■"
  foreachE d.willAlive <<< flip logTo' $ color Blue  "□"
    where
      logTo' = logTo rl

color :: Color -> String -> String
color = (<>) <<< case _ of
  Black -> "\x1b[30m"
  Green -> "\x1b[32m"
  Red   -> "\x1b[31m"
  Blue  -> "\x1b[34m"

Diffには現在と次世代の差分が入ります。replace関数の中ではその差分によって画面の更新処理を行います。logTo関数はnode.jsのreadlineモジュール、セルの座標、文字列を受け取り、指定された文字列をその位置に表示します。見た目の楽しさのために、color関数を使って表示する文字列に色を付けています。

画面の更新処理についてはこちらの記事に簡単な具体例を書いています。

ここではFFIを使っているので、対応するJavaScriptファイルを用意する必要があります。ファイル名はMain.pursに対応してMain.jsです。

Main.js

exports.consoleClear
  = console.clear;

exports.readline
  = function () {
      return require('readline');
    };

exports.cursorToImpl
  = function (readline, x, y) {
      readline.cursorTo(process.stdout, x, y);
    };

exports.logImpl
  = function (s) {
      process.stdout.write(s);
    };

exports.getRows
  = function () {
      return process.stdout.rows;
    };

exports.getColumns
  = function () {
      return process.stdout.columns;
    };

ゲームのメインループを作る

やっとプログラムを動かせるようになります。

main :: Effect Unit
main = do
  fs <- fieldSize
  rl <- readline
  consoleClear
  fieldInit rl fs $ color Black "□"
  replace rl (diff [] [] pattern)
  _  <- setTimeout 1000 $ loop rl fs [] pattern
  pure unit

pattern :: Pattern
pattern = []

loop :: Readline -> FieldSize -> Pattern -> Pattern -> Effect Unit
loop rl fs prev curr = do
  next <- nextGen fs curr # pure
  _    <- setTimeout 100 $ replace rl (diff prev curr next) *> loop rl fs curr next
  pure unit

diff :: Pattern -> Pattern -> Pattern -> Diff
diff prev curr next =
  { dead      : difference prev curr
  , willDead  : difference curr next
  , alive     : difference curr prev
  , willAlive : difference next curr
  }

fieldSize :: Effect FieldSize
fieldSize = { w: _, h: _ } <$> getColumns <*> getRows

fieldInit :: Readline -> FieldSize -> String -> Effect Unit
fieldInit rl fs s = foreachE (0 .. fs.w) \x -> foreachE (0 .. fs.h) \y -> logTo rl (Tuple x y) s

main関数では以下の順番で処理を行います。

fieldSize関数でターミナルエミュレータの画面サイズを取得する。
readline関数でnode.jsのreadlineモジュールを取得する。
consoleClear関数でコンソール上の文字を一掃する。
fieldInit関数でコンソール上の全セルを黒四角で埋める。
diff関数によって得た前世代・現在・次世代の差分情報を使ってreplace関数が画面を更新する。ここでは初期化直後のため前世代と現在は空にしてあるので、描画されるのは次に誕生するセルのみ。
1000ミリ秒後にループへ入る。

loop関数では、「3世代間の差分を出す→100ミリ秒待機→差分によって画面を更新する」を繰り返します。

実行すると、画面が黒い四角で埋め尽くされるだけで何も起こりません。pattern関数の配列に初期状態の生存セルを書く必要があります。

初期パターンを設定する

例えば、以下のようにして実行すると、青四角→赤四角と変化した後に過疎ルールの適用によって死亡してしまいます。

pattern :: Pattern
pattern = [ Tuple 3 5 ]

別のパターンを試してみます。

pattern :: Pattern
pattern = [ Tuple 3 5, Tuple 3 6, Tuple 4 5, Tuple 4 6 ]

このパターンは永久に生き続けるパターンで、ライフゲームでは「ブロック」と呼ばれます。

新たにblock関数を作り、以下のように書き換えてみます。

pattern :: Pattern
pattern = concat
  [ block
  , move 2 3 block
  ]

block :: Pattern
block = [ Tuple 3 5, Tuple 3 6, Tuple 4 5, Tuple 4 6 ]

これを動かすと、ブロックとブロックの間にセルが誕生し、ブロックが変形して消滅します。だんだんライフゲームっぽくなってきましたね。いろいろなパターンを作ってみてください（最後の章のソースコードに様々なパターンを載せておきました）。

次のパターンは「グライダー銃」として有名なパターンです。

gliderGun :: Pattern
gliderGun = [ Tuple 0 4, Tuple 0 5, Tuple 1 4, Tuple 1 5, Tuple 10 4, Tuple 10 5, Tuple 10 6, Tuple 11 3, Tuple 11 7, Tuple 12 2, Tuple 12 8, Tuple 13 2, Tuple 13 8, Tuple 14 5, Tuple 15 3, Tuple 15 7, Tuple 16 4, Tuple 16 5, Tuple 16 6, Tuple 17 5, Tuple 20 2, Tuple 20 3, Tuple 20 4, Tuple 21 2, Tuple 21 3, Tuple 21 4, Tuple 22 1, Tuple 22 5, Tuple 24 0, Tuple 24 1, Tuple 24 5, Tuple 24 6, Tuple 34 2, Tuple 34 3, Tuple 35 2, Tuple 35 3 ]

ソースコード全文

Main.purs

module Main where

import Prelude

import Data.Array (concat, difference, filter, intersect, length, nubEq, (..))
import Data.Tuple (Tuple(..))
import Effect (Effect, foreachE)
import Effect.Timer (setTimeout)
import Effect.Uncurried (EffectFn1, EffectFn3, runEffectFn1, runEffectFn3)

main :: Effect Unit
main = do
  fs <- fieldSize
  rl <- readline
  consoleClear
  fieldInit rl fs $ color Black "□"
  replace rl (diff [] [] pattern)
  _  <- setTimeout 1000 $ loop rl fs [] pattern
  pure unit

pattern :: Pattern
pattern = concat
  [ gliderGun
  , move 50 5 nebula
  , move 43 2 block
  ]

loop :: Readline -> FieldSize -> Pattern -> Pattern -> Effect Unit
loop rl fs prev curr = do
  next <- nextGen fs curr # pure
  _    <- setTimeout 100 $ replace rl (diff prev curr next) *> loop rl fs curr next
  pure unit

breeder :: Pattern
breeder = [ Tuple 0 5, Tuple 2 4, Tuple 2 5, Tuple 4 1, Tuple 4 2, Tuple 4 3, Tuple 6 0, Tuple 6 1, Tuple 6 2, Tuple 7 1 ]

gliderGun :: Pattern
gliderGun = [ Tuple 0 4, Tuple 0 5, Tuple 1 4, Tuple 1 5, Tuple 10 4, Tuple 10 5, Tuple 10 6, Tuple 11 3, Tuple 11 7, Tuple 12 2, Tuple 12 8, Tuple 13 2, Tuple 13 8, Tuple 14 5, Tuple 15 3, Tuple 15 7, Tuple 16 4, Tuple 16 5, Tuple 16 6, Tuple 17 5, Tuple 20 2, Tuple 20 3, Tuple 20 4, Tuple 21 2, Tuple 21 3, Tuple 21 4, Tuple 22 1, Tuple 22 5, Tuple 24 0, Tuple 24 1, Tuple 24 5, Tuple 24 6, Tuple 34 2, Tuple 34 3, Tuple 35 2, Tuple 35 3 ]

acorn :: Pattern
acorn = [ Tuple 0 2, Tuple 1 0, Tuple 1 2, Tuple 3 1, Tuple 4 2, Tuple 5 2, Tuple 6 2 ]

thunderbird :: Pattern
thunderbird = concat [ move 1 2 blinker, [ Tuple 0 0, Tuple 1 0, Tuple 2 0 ] ]

bHeptomino :: Pattern
bHeptomino = [ Tuple 0 0, Tuple 0 1, Tuple 1 1, Tuple 1 2, Tuple 2 0, Tuple 2 1, Tuple 3 0 ]

piHeptomino :: Pattern
piHeptomino = [ Tuple 0 0, Tuple 0 1, Tuple 0 2, Tuple 1 0, Tuple 2 0, Tuple 2 1, Tuple 2 2 ]

queenBee :: Pattern
queenBee = [ Tuple 0 0, Tuple 0 1, Tuple 0 5, Tuple 0 6, Tuple 1 2, Tuple 1 3, Tuple 1 4, Tuple 2 1, Tuple 2 5, Tuple 3 2, Tuple 3 4, Tuple 4 3 ]

blinker :: Pattern
blinker = [ Tuple 0 0, Tuple 0 1, Tuple 0 2 ]

trafficLight :: Pattern
trafficLight = [ Tuple 0 3, Tuple 0 4, Tuple 0 5, Tuple 4 0, Tuple 4 1, Tuple 4 2, Tuple 8 3, Tuple 8 4, Tuple 8 5, Tuple 4 6, Tuple 4 7, Tuple 4 8 ]

pulsar :: Pattern
pulsar = [ Tuple 5 6, Tuple 6 5, Tuple 5 8, Tuple 6 9, Tuple 8 5, Tuple 9 6, Tuple 8 9, Tuple 9 8, Tuple 1 4, Tuple 4 1, Tuple 1 10, Tuple 4 13, Tuple 10 1, Tuple 13 4, Tuple 13 10, Tuple 10 13, Tuple 4 6, Tuple 6 4, Tuple 4 8, Tuple 6 10, Tuple 8 4, Tuple 10 6, Tuple 8 10, Tuple 10 8, Tuple 0 4, Tuple 2 4, Tuple 0 10, Tuple 2 10, Tuple 12 4, Tuple 14 4, Tuple 12 10, Tuple 14 10, Tuple 4 0, Tuple 4 2, Tuple 4 12, Tuple 4 14, Tuple 10 0, Tuple 10 2, Tuple 10 12, Tuple 10 14, Tuple 2 5, Tuple 4 5, Tuple 5 2, Tuple 5 4, Tuple 2 9, Tuple 4 9, Tuple 5 10, Tuple 5 12, Tuple 9 2, Tuple 9 4, Tuple 10 5, Tuple 12 5, Tuple 9 10, Tuple 9 12, Tuple 10 9, Tuple 12 9 ]

nebula :: Pattern
nebula = [ Tuple 2 2, Tuple 3 2, Tuple 4 2, Tuple 5 2, Tuple 6 2, Tuple 7 2, Tuple 2 3, Tuple 3 3, Tuple 4 3, Tuple 5 3, Tuple 6 3, Tuple 7 3, Tuple 2 5, Tuple 2 6, Tuple 2 7, Tuple 2 8, Tuple 2 9, Tuple 2 10, Tuple 3 5, Tuple 3 6, Tuple 3 7, Tuple 3 8, Tuple 3 9, Tuple 3 10, Tuple 5 9, Tuple 6 9, Tuple 7 9, Tuple 8 9, Tuple 9 9, Tuple 10 9, Tuple 5 10, Tuple 6 10, Tuple 7 10, Tuple 8 10, Tuple 9 10, Tuple 10 10, Tuple 9 2, Tuple 9 3, Tuple 9 4, Tuple 9 5, Tuple 9 6, Tuple 9 7, Tuple 10 2, Tuple 10 3, Tuple 10 4, Tuple 10 5, Tuple 10 6, Tuple 10 7 ]

glider :: Pattern
glider = [ Tuple 1 0, Tuple 2 1, Tuple 0 2, Tuple 1 2, Tuple 2 2 ]

block :: Pattern
block = [ Tuple 0 0, Tuple 1 0, Tuple 0 1, Tuple 1 1 ]

tub :: Pattern
tub = [ Tuple 1 0, Tuple 0 1, Tuple 2 1, Tuple 1 2 ]

boat :: Pattern
boat = [ Tuple 0 0, Tuple 1 0, Tuple 0 1, Tuple 2 1, Tuple 1 2 ]

beeHive :: Pattern
beeHive = [ Tuple 1 0, Tuple 2 0, Tuple 0 1, Tuple 3 1, Tuple 1 2, Tuple 2 2 ]

ship :: Pattern
ship = [ Tuple 1 0, Tuple 2 0, Tuple 0 1, Tuple 2 1, Tuple 0 2, Tuple 1 2 ]

airclaftCarrier :: Pattern
airclaftCarrier = [ Tuple 0 0, Tuple 1 0, Tuple 0 1, Tuple 3 1, Tuple 2 2, Tuple 3 2 ]

barge :: Pattern
barge = [ Tuple 1 0, Tuple 0 1, Tuple 2 1, Tuple 1 2, Tuple 3 2, Tuple 2 3 ]

snake :: Pattern
snake = snake' 0

loaf :: Pattern
loaf = [ Tuple 1 0, Tuple 2 0, Tuple 0 1, Tuple 3 1, Tuple 1 2, Tuple 3 2, Tuple 2 3 ]

pond :: Pattern
pond = [ Tuple 1 0, Tuple 0 2, Tuple 1 3, Tuple 3 2, Tuple 2 0, Tuple 3 1, Tuple 0 1, Tuple 2 3 ]

snake' :: Int -> Pattern
snake' n = concat [ additional n, [ Tuple 0 0, Tuple 0 1, Tuple 1 0, Tuple 2 1, Tuple (3 + n) n, Tuple (3 + n) (n + 1) ] ]
  where
    additional n'
      | n' <= 0   = []
      | otherwise = concat [ additional $ n' - 1, [ Tuple (2 + n') (1 + n') ] ]

diff :: Pattern -> Pattern -> Pattern -> Diff
diff prev curr next =
  { dead      : difference prev curr
  , willDead  : difference curr next
  , alive     : difference curr prev
  , willAlive : difference next curr
  }

fieldSize :: Effect FieldSize
fieldSize = { w: _, h: _ } <$> getColumns <*> getRows

fieldInit :: Readline -> FieldSize -> String -> Effect Unit
fieldInit rl fs s = foreachE (0 .. fs.w) \x -> foreachE (0 .. fs.h) \y -> logTo rl (Tuple x y) s

type FieldSize
  = { w :: Int
    , h :: Int
    }

type Pos = Tuple Int Int

type Pattern = Array Pos

nextGen :: FieldSize -> Pattern -> Pattern
nextGen fs lives = concat >>> nubEq $ [ keeps, births ]
  where
    keeps  = filter (score fs lives >>> (==) 2) lives
    births = filter (score fs lives >>> (==) 3) $ map (neighbors fs) >>> concat $ lives

score :: FieldSize -> Pattern -> Pos -> Int
score fs lives = neighbors fs >>> intersect lives >>> length

neighbors :: FieldSize -> Pos -> Pattern
neighbors fs (Tuple x y) = [ Tuple (x-1) (y-1), Tuple x (y-1), Tuple (x+1) (y-1)
                           , Tuple (x-1) (y  ),                Tuple (x+1) (y  )
                           , Tuple (x-1) (y+1), Tuple x (y+1), Tuple (x+1) (y+1)
                           ] # map (wrap fs)

wrap :: FieldSize -> Pos -> Pos
wrap fs (Tuple x y) = Tuple (x `mod` fs.w) (y `mod` fs.h)

move :: Int -> Int -> Pattern -> Pattern
move x y = map (_ + Tuple x y)

data Readline

foreign import readline :: Effect Readline

foreign import consoleClear :: Effect Unit

foreign import cursorToImpl :: EffectFn3 Readline Int Int Unit

cursorTo :: Readline -> Int -> Int -> Effect Unit
cursorTo = runEffectFn3 cursorToImpl

foreign import logImpl :: EffectFn1 String Unit

log' :: String -> Effect Unit
log' = runEffectFn1 logImpl

logTo :: Readline -> Pos -> String -> Effect Unit
logTo rl (Tuple x y) c = cursorTo rl x y *> log' c

foreign import getRows :: Effect Int

foreign import getColumns :: Effect Int

data Color = Black | Green | Red | Blue

type Diff
  = { dead      :: Pattern
    , alive     :: Pattern
    , willDead  :: Pattern
    , willAlive :: Pattern
    }

replace :: Readline -> Diff -> Effect Unit
replace rl d = do
  foreachE d.dead      <<< flip logTo' $ color Black "□"
  foreachE d.alive     <<< flip logTo' $ color Green "■"
  foreachE d.willDead  <<< flip logTo' $ color Red   "■"
  foreachE d.willAlive <<< flip logTo' $ color Blue  "□"
    where
      logTo' = logTo rl

color :: Color -> String -> String
color = (<>) <<< case _ of
  Black -> "\x1b[30m"
  Green -> "\x1b[32m"
  Red   -> "\x1b[31m"
  Blue  -> "\x1b[34m"

Main.js

exports.consoleClear
  = console.clear;

exports.readline
  = function () {
      return require('readline');
    };

exports.cursorToImpl
  = function (readline, x, y) {
      readline.cursorTo(process.stdout, x, y);
    };

exports.logImpl
  = function (s) {
      process.stdout.write(s);
    };

exports.getRows
  = function () {
      return process.stdout.rows;
    };

exports.getColumns
  = function () {
      return process.stdout.columns;
    };

参考