プログラミング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
本当は不正入力への対応などもしたかったのですが、例外処理とかわけ分からないモナドとかの事情で断念しました。
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で作ったので公開しようかな
