プログラミングHaskellを読む(9)

いよいよモナドに近づいて来ました。

前章と比較しながら読むと、この章は前章の抽象化であることが分かります。

第9章 対話プログラム

基本

バッチプログラムは副作用がない。対話プログラムは入力が非決定的なので副作用が発生します。
では、副作用を起こす対話プログラムを純粋な関数としてみなすには?→世界を受け取る。

type IO a = World -> (a, World)

"IO a"型の関数は「アクション」と呼ばれます。

  • 3つの基本的な組み込みアクション
    • getChar :: IO Char
    • putChar :: IO ()
    • return :: a -> IO a

returnは純粋な式汚れたアクションへの橋渡しの役目。一度汚れたら純粋に戻る術はないので、returnの逆はありません。2つのアクションを繋げるのに、前章で出てきた">>=(そして)*1"が利用できます。do記法を利用するとよりクールです。

{-
so :: IO a -> (a -> IO b) -> IO b
f `so` g = \world -> case f world of
  (v, world') -> (g v) world'
-}

echo :: IO ()
echo =
  getChar >>= \c ->
  putChar '\n' >>= \t1 ->
  putChar c >>= \t2 ->
  putChar '\n'

echo' :: IO ()
echo' = do c <- getChar
           putChar '\n'
           putChar c
           putChar '\n'

so関数は上記の定義で問題無さそうに見えるのですが、

    The lambda expression `\ world -> ...' has one argument,
    but its type `IO b' has none
    In the expression:
      \ world -> case f world of { (v, world') -> (g v) world' }
    In an equation for `so':
        f so g = \ world -> case f world of { (v, world') -> (g v) world' }

というエラーが出ます。何故???

ちなみに、">>="演算子は、今回扱っているIOの上位概念(?)となるMonadを利用して型定義されています。

> :t (>>=)
(>>=) :: Monad m => m a -> (a -> m b) -> m b

getChar, putChar, return, >>=を利用すれば、色々な部品を作成出来ます。

-- 一行取得
getLine' :: IO String
getLine' = do x <- getChar
              if x == '\n'
                then return []
                else do xs <- getLine'
                        return (x : xs)

-- 文字列の出力
putStr' :: String -> IO ()
putStr' [] = return ()
putStr' (x:xs) = do putChar x
                    putStr' xs

-- putStrに改行を付加
putStrLn' :: String -> IO ()
putStrLn' xs = do putStr' xs
                  putChar '\n'

-- 文字を入力させ、その文字数を出力するサンプル
-- showは文字列変換関数
strlen :: IO ()
strlen = do putStr' "Enter a string: "
            xs <- getLine'
            putStr' "The string has "
            putStr' (show (length xs))
            putStrLn' " characters"

{- ココらへんから後半への準備に入る。エスケープは多分シェル依存。 -}

-- ビープ音
beep :: IO ()
beep = putStr "\BEL"

-- 画面クリア
cls :: IO ()
cls = putStr "\ESC[2J"

-- 位置型
type Pos = (Int, Int)

-- カーソルを移動
goto :: Pos -> IO ()
goto (x, y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")

-- 指定位置に文字を出力
writeat :: Pos -> String -> IO ()
writeat p xs = do goto p
                  putStr xs

-- 配列にあるアクションを順番に実行
seqn :: [IO a] -> IO ()
seqn [] = return ()
seqn (a:as) = do a
                 seqn as

-- おまけ:seqnを使ったputStr
putStr_ xs = seqn [putChar x | x <- xs]

もうCUIも怖くないですね。

電卓

楽しい楽しいアプリ制作のお時間です。と思ったら前章のパーサが必要でした、残念。第8章に戻った後にやることにします。

ライフゲーム

ライフゲーム (Conway's Game of Life[1]) は1970年にイギリスの数学者ジョン・ホートン・コンウェイ (John Horton Conway) が考案した生命の誕生、進化、淘汰などのプロセスを簡易的なモデルで再現したシミュレーションゲームである。単純なルールでその模様の変化を楽しめるため、パズルの要素を持っている。
生物集団においては、過疎でも過密でも個体の生存に適さないという個体群生態学的な側面を背景に持つ。セル・オートマトンのもっともよく知られた例でもある。

ライフゲーム - Wikipedia

という、単純なルールで実装も簡単な割に見た目が派手で楽しいゲームです*2

-- ビープ音
beep :: IO ()
beep = putStr "\BEL"

-- 画面クリア
cls :: IO ()
cls = putStr "\ESC[2J"

-- 位置型
type Pos = (Int, Int)

-- カーソルを移動
goto :: Pos -> IO ()
goto (x, y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")

-- 指定位置に文字を出力
writeat :: Pos -> String -> IO ()
writeat p xs = do goto p
                  putStr xs

-- 配列にあるアクションを順番に実行
seqn :: [IO a] -> IO ()
seqn [] = return ()
seqn (a:as) = do a
                 seqn as

-------------------------

width :: Int
width = 20
height :: Int
height = 20

type Board = [Pos]

-- グライダー
glider :: Board
glider = [(4,2), (2,3), (4,3), (3,4), (4,4)]

-- 生きているか(Board内にPosがあるか)
isAlive :: Board -> Pos -> Bool
isAlive b p = elem p b

{-
復習:elemは配列にその要素が含まれているか調べる関数。
> elem 10 [1,2,3]
False
> elem 10 [1,2,10]
True
-}

-- 死んでいるか
isEmpty :: Board -> Pos -> Bool
isEmpty b p = not (isAlive b p)

-- 周囲のセルを返す。周囲は繋げる。
neighbs :: Pos -> [Pos] 
neighbs (x,y) =
  map wrap [(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)]
  where
    wrap (x,y) = (((x-1) `mod` width) + 1, ((y-1) `mod` height) + 1)
                     
{- neighbsの戻り値は[Pos]型でBoard型ではない。
確かに[Pos]型はBoard型と同じだけれど、Boardはそれがゲームのボードとして完成している時(実際にそれを表示する時)に使われるべき型なので、区別しているのだと思う。
-}

-- 周囲の生きている個数を調べる
liveneighbs :: Board -> Pos -> Int
liveneighbs b = length . filter (isAlive b) . neighbs

-- 生き残るセル
survivors :: Board -> [Pos]
survivors b = [p | p <- b, elem (liveneighbs b p) [2,3]]
{-
Boardには現在生きているセルのPosが入っている。
生き残る条件は、周囲で生きているセルが2個か3個。
生きているセルだけ調べればよいので、Boardを直接参照すれば良い。
値の範囲調査にelemを使っているところがミソ。
-}

-- 新しく誕生するセル
births :: Board -> [Pos]
{- 性能悪い版
births b = [(x,y) | x <- [1..width],
                  | y <- [1..height],
                    isEmpty b (x,y),
                    liveneighbs b (x,y) == 3]

新しく誕生する条件は、周囲に生きているセルが3個である時。
生きているセルはチェックする必要がないのでisEmptyで排除。
生きているセルの回りだけ調べることで最適化出来る。
-}
births b = [p | p <- rmdups (concat (map neighbs b)),
            isEmpty b p,
            liveneighbs b p == 3]
  where
    -- リスト内の重複を排除する関数
    rmdups xs = case xs of
      [] -> []
      (x:xs) -> x : rmdups (filter (/= x) xs)

{-
concat (map neighbs b)
でBoard内の生きている全てのPosの周りのセルのPosがリストで得られる。
重複するPosがある可能性があるのでrmdupsで排除する。
-}

-- 次世代のBoard
nextgen :: Board -> Board
nextgen b = survivors b ++ births b

{- ここまで一切副作用なし!快適!! -}

-- 指定されたBoardを表示
showcells :: Board -> IO ()
showcells b = seqn [writeat p "o" | p <- b]

-- ライフゲームのメインループ
life :: Board -> IO ()
life b = do cls
            showcells b
            wait 100000 -- テキストの5000じゃ早すぎた
            life (nextgen b)
              where
                -- 無駄なアクションで時間を稼ぐ関数(ビジーループ)
                wait n = seqn [return () | _ <- [1..n]]

"life glider"とすればチクチク動いてくれます。

練習問題

電卓ネタは実装できていないので飛ばします。

1. readLine(DEL対応版getLine)

getLineを改造するだけでは、入力を消すことができないので、アキュームレータを使ってみました。

readLine :: IO String
readLine = loop []
  where
    -- n文字「画面上の文字を」消す関数
    del n = putStr (concat ["\ESC[1D \ESC[1D" | _ <- [1..n]])
    -- アキュームレータを使った内部ループ
    loop xs = 
      do x <- getChar
         case x of
           '\n' -> return xs
           '\DEL' -> if null xs
	   	     -- "\DEL"により"^?"の二文字が表示されるのでそれを消す。
                     then do del 2
                             loop xs
                     else do del 3
                             loop (init xs)
           otherwise -> loop (xs ++ [x])
2. 電卓でエラー位置の表示

電卓系なので略

3. 無駄な画面消去を減らす

IO部分を少しいじれば良いです。

-- 差分を表示
showcells' :: Board -> Board -> IO ()
showcells' pb nb =
  -- pbにあってnbに無い所は消す。
  -- nbにあってpbに無い所は表示する。
  do seqn [writeat p " " | p <- [p' | p' <- pb, elem p' nb]]
     seqn [writeat p "o" | p <- [p' | p' <- nb, elem p' pb]]

life' :: Board -> IO ()
life' b = do showcells' b nb
             wait 100000
             life nb
               where
                 nb = nextgen b
                 wait n = seqn [return () | _ <- [1..n]]
4. Boardを対話的に作成、変更できるライフゲーム

実行中に中断してBoardを編集できるようにするとなると、マルチスレッドや割り込み制御しないとけないのですが、それは面倒なので、最初だけ編集ができるようにしてみました。

widthとheightを書き換えることは副作用になるので出来ません。もし変えたいのであればBoardにwidthとheightの情報を持たせる必要があり、全面的に書きなおさないといけないため、面倒なのでやめました。

基本的な方針は以下のように決定。

lifeEdit :: IO Board
lifeEdit = do cls
              showcells glider
              putChar '\n'
              putStrLn "e: edit, s: start (default: s)"
              putStr "input: "
              c <- getLine
              case c of
                "e" -> do putStr "x: "
                          x <- readLn :: IO Int
                          putStr "y: "
                          y <- readLn :: IO Int
                          -- ToDo: 不正な入力なら再度入力させる処理にする
                          if elem (x,y) glider
                            then return (filter (/= (x,y)) glider)
                            else return ((x,y) : glider)
                "s" -> return glider
                otherwise -> return glider

このlifeEdit関数のgliderを変数に置き換え、再帰させれば編集部分はできそうです。

lifeEdit :: Board -> IO Board
lifeEdit b = do cls
                showcells b
                putChar '\n'
                putStrLn "e: edit, s: start"
                putStr "op: "
                c <- getLine
                case c of
                  "e" -> do putStr "x: "
                            x <- readLn :: IO Int
                            putStr "y: "
                            y <- readLn :: IO Int
                            if elem (x,y) b
                              then lifeEdit (filter (/= (x,y)) b)
                              else lifeEdit ((x,y) : b)
                  "s" -> return b
                  otherwise -> lifeEdit b

-- lifeStarterは
-- lifeEditで作成したboradを
-- life'で実行する関数
lifeStarter :: IO ()
lifeStarter = do b <- lifeEdit glider
                 life' b

本当は不正入力への対応などもしたかったのですが、例外処理とかわけ分からないモナドとかの事情で断念しました。

5. 計算機とライフゲームGUI

省略。よほど暇だったらやるかもしれません。

6. ニム(nim)

概要はWikipediaを参照。必勝法に関する理論は英語版の方が充実してます。

-- ビープ音
beep :: IO ()
beep = putStr "\BEL"

-- 画面クリア
cls :: IO ()
cls = putStr "\ESC[2J"

-- 位置型
type Pos = (Int, Int)

-- カーソルを移動
goto :: Pos -> IO ()
goto (x, y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")

-- 指定位置に文字を出力
writeat :: Pos -> String -> IO ()
writeat p xs = do goto p
                  putStr xs

-- 配列にあるアクションを順番に実行
seqn :: [IO a] -> IO ()
seqn [] = return ()
seqn (a:as) = do a
                 seqn as

-----------------------------------------

type Board = [Int]

-- 初期状態
firstboard :: Board
firstboard = [5,4,3,2,1]

-- n行目の星の数を取得
getstars :: Board -> Int -> Int
getstars b n = b !! (n-1)

-- n行目の星の数を変更したBoardの生成
setstars :: Board -> Int -> Int -> Board
setstars b n s = (take (n-1) b) ++ [s] ++ (drop n b)

-- n行目の星をs個除く。sが大きかったらその行は0。
takestars :: Board -> Int -> Int -> Board
takestars b n s = setstars b n stars
  where
    stars = if t < 0 then 0 else t
      where t = getstars b n - s

-- 勝利してるか(=取り終わったか)
won :: Board -> Bool
won b = sum [getstars b n | n <- [1..length b]] == 0

-- 手抜きPlayer管理
type Player = String
playerA :: Player
playerA = "A"
playerB :: Player
playerB = "B"
turn :: Player -> Player
turn p = if p == playerA then playerB else playerA

-- Boardの表示
showboard :: Board -> IO ()
showboard b = seqn [showline n | n <- [1..length b]]
  where
    -- n行目を表示
    showline n = putStrLn ((show n) ++ ":" ++ (replicate (getstars b n) '*'))

-- メインループ
nim :: Board -> Player -> IO ()
nim b p =
  do cls
     goto (0, 0)
     showboard b
     putChar '\n'
     putStrLn (p ++ "'s turn")
     putStr "line: "
     n <- readLn :: IO Int
     putStr "take: "
     s <- readLn :: IO Int
     nb <- return (takestars b n s)
     if won nb
       then do putStrLn (p ++ " win!")
               putStr "Press any key to restart"
               getChar
               startnim
       else nim nb (turn p)
     
-- ゲーム開始
startnim :: IO ()
startnim = nim firstboard playerA

*1:[http://shin.hateblo.jp/entry/2012/08/20/162226:title=前のエントリ]でいえばso関数

*2:先日、暇つぶしとしてJavaScriptで作ったので公開しようかな