具体例で学ぶHaskell

はじめに

前回 すごいH本が楽しかったのでまとめた という記事を書きました．
Haskellの勉強が楽しかったので，『プログラミングHaskell』を読みました．
その内容の簡単なまとめ記事です．

関数型パーサー

第8章の内容になります．
関数を組み合わせて便利なパーサーを構築する過程が面白かったので，題材として取り上げました．

パーサーの型

a 型のパーサーを，String 型を受け取り，Maybe (a, String) 型を返す関数として定義します．
失敗する場合を扱えるように Maybe を用いています．
Maybe の中身は，a 型の結果と消費されなかった残りの文字列のタプルになります．
定義は以下のようになります．

type Parser a = String -> Maybe (a, String)

基本的なパーサー

基本的なパーサーから始め，徐々に便利なパーサーを構築します．
a 型の値と入力文字列を受け取り，文字列を消費しないパーサーを返す関数 return' を定義します．

return' :: a -> Parser a
return' v s = Just (v, s)

入力文字列にかかわらず常に失敗する関数 failure を定義します．

failure :: Parser a
failure s = Nothing

入力文字列が空なら失敗し，そうでなければ最初の文字を消費する関数 item を定義します．

item :: Parser Char
item []     = Nothing
item (x:xs) = Just (x, xs)

それぞれの関数を試してみます．

ghci> return' 1 "abc"
Just (1,"abc")

ghci> failure "abc"
Nothing

ghci> item ""
Nothing

ghci> item "abc"
Just ('a',"bc")

連結と選択

まず，パーサーを連結させることを考えます．
入力文字列に1番目のパーサー p を適用し，失敗すれば全体も失敗します．
成功の場合は，1番目のパーサーの結果 v に関数 f を適用し，2番目のパーサを生成します．
この2番目のパーサーに1番目のパーサーの結果の残りの文字列 s' を渡すと最終的な結果が得られます．

(>>==) :: Parser a -> (a -> Parser b) -> Parser b
p >>== f = \s -> case p s of
    Nothing -> Nothing
    Just (v, s') -> f v s'    

文字を3つ消費し，1番目と3番目を組にして返してみます．

ghci> (item >>== \x -> item >>== \y -> item >>== \z -> return' (x, z)) "abcdef"
Just (('a','c'),"def")

次にパーサーの結果を選択することを考えます．
1番目のパーサーに入力文字列を渡し，成功したらその結果を，失敗したら2番目のパーサーを適用した結果を返します．

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = \s -> case p s of
    Nothing -> q s
    Just (v, s') -> Just (v, s')

いくつか試してみます．

ghci> (item +++ return 'd') "abc"
Just ('a', "bc")

ghci> (failure +++ return 'd') "abc"
Just ('d', "abc")

ghci> (failure +++ failure) "abc"
Nothing

パーサーの部品

基本的なパーサーと，連結や選択を組み合わせると意味のあるパーサーを定義できます．
sat, string, many, many1 を見ていきます．

sat
述語 p を満足する一文字用のパーサー sat を以下のように定義します．

sat :: (Char -> Bool) -> Parser Char
sat p = item >>== \c -> if p c
    then return' c
    else failure

sat に色々な述語を渡すと，特定の文字に対するパーサーを定義できます．

import Data.Char

digit :: Parser Char
digit = sat isDigit

lower :: Parser Char
lower = sat isLower

alphanum :: Parser Char
alphanum = sat isAlphaNum

char :: Char -> Parser Char
char x = sat (== x)

試してみます．

ghci> digit "123"
Just ('1',"23")

ghci> digit "abc"
Nothing

ghci> char 'a' "abc"
Just ('a',"bc")

ghci> char 'a' "123"
Nothing

string
パーサー char を使ってパーサー string を定義します．
パーサー string は，引数の文字列がすべて消費される場合に限って成功します．

string :: String -> Parser String
string [] = return' []
string (x:xs) = char x >>== \_ -> string xs >>== \_ -> return' (x:xs)

Parser をモナドインスタンスとして宣言していれば，do記法で以下のように定義できます．

string :: String -> Parser String
string [] = return []
string (x:xs) = do
    char x
    string xs
    return (x:xs)

例を使って動作を追いかけてみます．
パーサー char で一文字目を消費し，成功なら Just を，失敗なら Nothing を返します．
Just の場合次のパーサー string に残りの文字列が渡されます．
string "abc" は，全てが成功した場合 Just ("abc", 残りの文字列) を返し，
どこかで失敗した場合 Nothing を返すパーサーです．

string "abc"
char 'a' >>== \_ -> string "bc" >>== \_ -> return' ('a':"bc")
-- 入力文字列の先頭が 'a' かつ string "bc" の戻り値が Just なら Just ("abc", 残りの文字列) を返す

string "bc"
char 'b' >>== \_ -> string "c" >>== \_ -> return' ('b':"c")
-- 入力文字列の先頭が 'b' かつ string "c" の戻り値が Just なら Just ("bc", 残りの文字列) を返す

string "c"
char 'c' >>== \_ -> string "" >>== \_ -> return' ('c':"")
-- 入力文字列の先頭が 'c' なら Just ("c", 残りの文字列)を返す

string ""
return' ""
-- Just ("", 入力文字列) を返す

ghci> string "abc" "abcdef"
Just ("abc", "def")

ghci> string "abc" "abdef"
Nothing

many, many1
many と many1 はパーサーを失敗するまで適用し，成功した結果をリストにして返します．
many はパーサーを0回以上，many1 はパーサーを1回以上適用します．

many :: Parser a -> Parser [a]
many p = many1 p +++ return' []

many1 :: Parser a -> Parser [a]
many1 p = p >>== \v -> many p >>== \vs -> return' (v:vs)

many は，+++ により return' を選択しているため，many1 が失敗しても Just を返します．
many1 は，述語 p を1回適用したのち，その結果に many を連結しています．

ghci> many digit "123abc"
Just ("123","abc")

ghci> many digit "abcdef"
Just ("","abcdef")

パーサー many, many1 を使ってパーサー ident, nat, space を定義します．
ident は識別子，nat は自然数，space は空白のパーサーです．

ident :: Parser String
ident = lower >>== \x -> many alphanum >>== \xs -> return' (x:xs)

nat :: Parser Int
nat = many1 digit >>== \xs -> return' (read xs)

space :: Parser ()
space = many (sat isSpace) >>== \_ -> return' ()

それぞれの関数を試してみます．

ghci> ident "abc def"
Just ("abc"," def")

ghci> nat "123 abc"
Just (123," abc")

ghci> space "  abc"
Just ((),"abc")

前後の空白を無視する token を定義し，ident, nat を強化します．

token :: Parser a -> Parser a
token p = space >>== \_ -> p >>== \v -> space >>== \_ -> return' v

identifier :: Parser String
identifier = token ident

natural :: Parser Int
natural = token nat

これもそれぞれ試してみます．

ghci> identifier "   abc def"
Just ("abc","def")

ghci> natural "  123  456  "
Just (123,"456  ")

切符番号遊び

11章の内容になります．
計算に使用できる自然数と四則演算を組み合わせて，目標の数になる計算式を作成するゲームです．
使用する自然数の個数は任意であり，使えるのはそれぞれ一回ずつです．
途中計算に出てくる数も自然数でなければならないという制約があります．
例えば，与えられた自然数が1, 3, 7, 10, 25, 50であり，目標の数を765とします．
解の一つは (1 + 50) * (25 - 10) になります．

(1 + 50) * (25 - 10)
= 51 * (25 - 10)
= 51 * 15
= 765

演算の定義

まず，四則演算子の型を定義します．
valid は重複を排除するために工夫をしています．

data Op = Add | Sub | Mul | Div deriving (Show)

-- 演算子を適用した結果が自然数となるか否かを返す
valid :: Op -> Int -> Int -> Bool
valid Add x y = x <= y -- x + y = y + x より x <= y の場合のみ計算すれば良い
valid Sub x y = x > y -- 結果は自然数でなければならないので x > y
valid Mul x y = x /= 1 && y /= 1 && x <= y -- 結果が変わらないので 1 を除く
valid Div x y = y /= 1 && x `mod` y == 0 -- 結果が変わらないので 1 を除く

-- 演算子を適用した結果を返す
apply :: Op -> Int -> Int -> Int
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = x `div` y

次に，数式の型を定義します．
数式は，自然数or二つの式への演算子適用を表します．
eval は空リストで失敗を表現します．

data Expr = Val Int | App Op Expr Expr deriving (Show)

-- 式の中の自然数をリストとして返す
values :: Expr -> [Int]
values (Val n) = [n]
values (App _ l r) = values l ++ values r

-- 式全体の値を返す
eval :: Expr -> [Int]
eval (Val n) = [n | n > 0]
eval (App o l r) = [apply o x y | x <- eval l, y <- eval r, valid o x y]

以下のように動きます．

-- (3 - 2) + (4 * 5)
ghci> values $ App Add (App Sub (Val 3) (Val 2)) (App Mul (Val 4) (Val 5))
[3,2,4,5]
ghci> eval $ App Add (App Sub (Val 3) (Val 2)) (App Mul (Val 4) (Val 5))
[21]

組み合わせ

組み合わせを扱う便利な関数を定義します．
これから紹介する関数はどれも感動するものばかりです．

subs
リストの部分リストを返します．
例えば，[1,2,3] に対する全ての部分リストは
[[],[1],[2],[3],[1,2],[1,3],[2,3],[1,2,3]] になります．
各要素を使うか否かなので，生成される部分リストは，2^(リストの長さ)パターンになります．
以下のように定義します．

subs :: [a] -> [[a]]
subs [] = [[]]
subs (x:xs) = ys ++ map (x:) ys
    where ys = subs xs

空リストを受け取った場合，ネストした空リストを返します．
そうでなければ，tail xs から生成される部分リスト ys と，
head x を ys の先頭に追加したリスト map (x:) ys を結合したものを返します．
動きを追って見てみます．

subs [1,2,3]
subs [2,3] ++ map (1:) subs [2,3] -- (1)

subs [2,3]
subs [3] ++ map (2:) subs [3] -- (2)

subs [3]
subs [] ++ map (3:) subs []
[[]] ++ map (3:) [[]]
[[],[3]] -- (3)

-- (2) へ (3) を渡す
subs [2,3]
[[],[3]] ++ map (2:) [[],[3]]
[[],[3],[2],[2,3]] -- (4)

-- (1) へ (4) を渡す
subs [1,2,3]
[[],[3],[2],[2,3]] ++ map (1:) [[],[3],[2],[2,3]]
[[],[3],[2],[2,3],[1],[1,3],[1,2],[1,2,3]]

interleave
リストに新たな要素を挿入したリストを返します．
例えば，新たな要素 1 を [2,3,4] に挿入した結果は，
[[1,2,3,4],[2,1,3,4],[2,3,1,4],[2,3,4,1]] になります．
以下のように定義します．

interleave :: a -> [a] -> [[a]]
interleave x [] = [[x]]
interleave x (y:ys) = (x:y:ys) : map (y:) (interleave x ys)

空リストに要素を追加した場合，追加要素のみのネストしたリストを返します．
そうでなければ，先頭に新たな要素 x を追加したリスト (x:y:ys) と，
リストのtail ys に新たな要素 x を追加したリスト interleave x ys の先頭に head y を追加したリストを
結合したものを返します．
動きを追って見てみます．

interleave 1 [2,3,4]
(1:2:[3,4]) : map (2:) (interleave 1 [3,4]) -- (1)

interleave 1 [3,4]
(1:3:[4]) : map (3:) (interleave 1 [4]) -- (2)

interleave 1 [4]
(1:4:[]) : map (4:) (interleave 1 [])
[1,4] : map (4:) [[1]]
[1,4] : [[4,1]]
[[1,4],[4,1]] -- (3)

-- (3) を (2) へ渡す
interleave 1 [3,4]
[1,3,4] : map (3:) [[1,4],[4,1]]
[1,3,4] : [[3,1,4],[3,4,1]]
[[1,3,4],[3,1,4],[3,4,1]] -- (4)

-- (4) を (1) へ渡す
interleave 1 [2,3,4]
[1,2,3,4] : map (2:) [[1,3,4],[3,1,4],[3,4,1]]
[1,2,3,4] : [[2,1,3,4],[2,3,1,4],[2,3,4,1]]
[[1,2,3,4],[2,1,3,4],[2,3,1,4],[2,3,4,1]]

perms
リストの要素の順列を返します．
例えば，[1,2,3] の順列は，
[[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]] になります．
以下のように定義します．

perms :: [a] -> [[a]]
perms [] = [[]]
perms (x:xs) = concat $ map (interleave x) (perms xs)

空リストの場合，ネストした空リストを返します．
そうでなければ，tail xs の順列に interleave を適用してhead x を新たな要素として挿入します．
動きを追って見てみます．

perms [1,2,3]
concat $ map (interleave 1) (perms [2,3]) -- (1)

perms [2,3]
concat $ map (interleave 2) (perms [3]) -- (2)

perms [3]
concat $ map (interleave 3) (perms [])
concat $ map (interleave 3) [[]]
concat $ [[[3]]]
[[3]] -- (3)

-- (3) を (2) へ渡す
perms [2,3]
concat $ map (interleave 2) [[3]]
concat $ [[[2,3],[3,2]]]
[[2,3],[3,2]] -- (4)

-- (4) を (1) へ渡す
perms [1,2,3]
concat $ map (interleave 1) [[2,3],[3,2]]
concat $ [[[1,2,3],[2,1,3],[2,3,1]],[[1,3,2],[3,1,2],[3,2,1]]]
[[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]]

choices
リストから選択肢を返します．
上記の素晴らしい関数を適用していくだけです．
subs により生成された部分リストに map perms で順列を取り，
最後に concat して平らにしています．

choices :: [a] -> [[a]]
choices xs = concat $ map perms $ subs xs

split
リストを空でない二つのリストに分割して返します．
例えば，[1,2,3,4] を分割した結果は，[([1],[2,3,4]),([1,2],[3,4]),([1,2,3],[4])] になります．
以下のように定義します．

split :: [a] -> [([a], [a])]
split [] = []
split [_] = []
split (x:xs) = ([x], xs) : [(x:ls, rs) | (ls, rs) <- split xs]

空リストor要素数1のリストの場合，空リストを返します．
そうでなければ，([x], xs) なるタプルとtail xs を分割した結果の左要素のリストの先頭に head x を加えたものを
結合して返します．
動きを追って見てみます．

split [1,2,3,4]
([1], [2,3,4]) : [(1:ls, rs) | (ls, rs) <- split [2,3,4]] -- (1)

split [2,3,4]
([2], [3,4]) : [(2:ls, rs) | (ls, rs) <- split [3,4]] -- (2)

split [3,4]
([3], [4]) : [(3:ls, rs) | (ls, rs) <- split [4]]
[([3], [4])] -- (3)

-- (2) へ (3) を渡す
split [2,3,4]
([2], [3,4]) : [(2:ls, rs) | (ls, rs) <- [([3], [4])]]
([2], [3,4]) : [([2,3],[4])]
[([2],[3,4]),([2,3],[4])] -- (4)

-- (1) へ (4) を渡す
split [1,2,3,4]
([1], [2,3,4]) : [(1:ls, rs) | (ls, rs) <- [([2],[3,4]),([2,3],[4])]]
([1], [2,3,4]) : [([1,2],[3,4]),([1,2,3],[4])]
[([1],[2,3,4]),([1,2],[3,4]),([1,2,3],[4])]

問題を解く

組み合わせ関数を使って切符番号遊びを解きます．
まず，式と式全体を評価した値の組を表す型を定義します．

type Result = (Expr, Int)

-- 2つの Result を受け取り，結果が自然数となる四則演算の結果 [Result] を返す
combine :: Result -> Result -> [Result]
combine (l, x) (r, y) = [(App o l r, apply o x y) | o <- [Add, Sub, Mul, Div], valid o x y]

-- 自然数のリストを受け取り，それぞれの値が一回だけ使われている全ての式を返す
results :: [Int] -> [Result]
results [] = []
results [n] = [(Val n, n) | n > 0]
results ns = [res | (ls, rs) <- split ns,
    lx <- results ls,
    ry <- results rs,
    res <- combine lx ry]

切符番号遊びを満たす全ての式を返す関数 solutions を定義できます．
results は与えられた自然数リストの値が一回だけ使われる全ての式を返すので，
choices によって ns から選択肢 ns' を生成し，ns' を results に渡します．
得られた値 m が目標となる値 n と等しくなるときの式 e が最終的な結果となります．

solutions :: [Int] -> Int -> [Expr]
solutions ns n = [e | ns' <- choices ns,
    (e, m) <- results ns',
    m == n]

おわりに

パーサーと切符番号遊びを具体例にHaskellを学ぶことができました．