Haskell で小町算

前回 Lua で挑戦した小町算 [2] に今度は Haskell で挑戦して見たいと思います。どうやって考えたかも含めて説明していきます。

Haskell には Lua と違って eval 相当（Lua の場合 loadstring 関数ですが）がないので別のアプローチを取る必要があります。
1つには Lua でやったのと同様に文字列で式を作って eval 相当の関数を書いてしまうというのもありますが、あまり綺麗な形式化ではない気もするので、最初から構文木のバリエーションを生成して基準に合うものを選ぶという方法を取る事にしました。

実は先日感想 [3] を書いた Programming in Haskell （以下 PiH と略す）には Countdown Problem という小町算に似ていなくもないパズルを Haskell で解いている章があります。ここから考え方の一部を借りて小町算を解いてみます。

* 道具立て

式を表現するためのデータ型として以下のようなものを定義します。

data Op = Add | Sub | Mul | Div | Cat
data Expr = Val Float | App Op Expr Expr

これは PiH とほぼ同じですが演算子に Cat というものを加えました。これは小町算では「数字を連結」という表現が許されるので、統一的に扱うためです。Cat 演算子は「左辺に10をかけたものに右辺を足す」という操作を行うものと定義できます。

以下が上記の Expr 型の式を評価する apply 関数と eval 関数です。

apply :: Op -> Float -> Float -> Float
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = x / y
apply Cat x y = x * 10 + y

eval :: Expr -> Float
eval (Val n) = n
eval (App o l r) = apply o (eval l) (eval r)

PiH ではやっていませんが show 関数を定義しておくと Hugs で試すときなど何かと便利なので以下のように定義しました。

instance Show Expr where
  show (Val n) = show (floor n)
  show (App Add l r) = (show l) ++ "+" ++ (show r)
  show (App Sub l r) = (show l) ++ "-" ++ (show r)
  show (App Mul l r) = (show l) ++ "*" ++ (show r)
  show (App Div l r) = (show l) ++ "/" ++ (show r)
  show (App Cat l r) = (show l) ++ (show r)

Val n の表示で floor 関数を適用しているのは 1.0+2.0 でなく 1+2 のように表示させるためです。最初から Int にしないのは割り算が切り詰められると困るためです。
（余談ですが Haskell の組み込み型に対する show 関数は普通再入力可能な表現が得られるようになっているようですがユーザ定義型も本当はそのようにするのが作法なのでしょうか）

* 式の生成 (1)

これを元にまず与えられた数のリストから可能な式を全て生成する combine 関数を書いてみます。ここがこのプログラムの肝になるはずです。

combine :: [Float] -> [Expr]
combine [] = []
combine [x] = [Val x]
combine xs = [App op l r | {- ... -} ]

リストが空だった場合に何も生成しないのと、1要素だった場合に Val しかないのは自明だと思います。
複数要素だった場合は何らかの演算子を使った式になります。これは演算子のバリエーションと左辺のバリエーションと右辺のバリエーションを掛け合わせたものになるのでリスト内包表記を使うとうまく書けそうです。

まず演算子のバリエーションは利用可能な演算子のリストをジェネレータに持ってくれば OK でしょう。

combine xs = [App op l r |  op <- ops, {- ... -} ]

ops :: [Op]
ops = [Add, Sub, Mul, Div, Cat]

右辺と左辺のバリエーションは数のリストをいくつずつ左右に振り分けるのかのバリエーションが得られれば combine を再帰的に適用することにより得られるはずです。

リストの左右振り分けのバリエーションを作る関数は PiH から split 関数をそのままもらってきました。

combine xs = [App op l r | op <- ops,
                           (ls, rs) <- split xs,
                           l <- combine ls,
                           r <- combine rs]

一旦ここで combine 関数の出来具合を試して見ます。

Main> combine [1,2,3]
[1+2+3,1+2-3,1+2*3,1+2/3,1+23,1+2+3,1-2+3,1*2+3,1/2+3,12+3,1-2+3,1-2-3,1-2*3,1-2
/3,1-23,1+2-3,1-2-3,1*2-3,1/2-3,12-3,1*2+3,1*2-3,1*2*3,1*2/3,1*23,1+2*3,1-2*3,1*
2*3,1/2*3,12*3,1/2+3,1/2-3,1/2*3,1/2/3,1/23,1+2/3,1-2/3,1*2/3,1/2/3,12/3,12+3,12
-3,12*3,12/3,123,1+23,1-23,1*23,1/23,123]

一見よさそうですが良く見るとかなりの重複が見られます。何がいけないのでしょうか。

* 問題点

実はこの combine 関数には以下のような問題があり、小町算に不要な（不正な）式まで生成するようになっています。

1. 同一レベルで右結合する場合がある

この問題の小町算では括弧の使用はできないので 1+2+3 は (1+2)+3 に相当する構文木だけが正で 1+(2+3) は不正です。

2. 自分より結合度の低い演算子が子ノード以下に現れる場合がある

括弧の使用は出来ないので (1+2)*3 に相当する式は不正です

3. Cat 演算子が右にブランチする場合がある

Cat 演算子は必ず左結合しなければなりません (1 cat 2) cat 3 は 123 ですが 1 cat (2 cat 3) だと 33 の意味になってしまいます。

こうした問題はパターンの生成に以下のような制約をつけることによって排除できます。

- 式の左辺にはそのノードの演算子と同じレベルか低いレベルの演算子のノードのみ来ることができる
- 式の右辺にはそのノードの演算子より低いレベルの演算子のノードのみ来ることができる
- 結合度は弱い順に Add, Sub > Mul, Div > Cat

そこで演算子にはレベルの情報を持たせて combine 関数がそのレベル情報を元に上記の制約を付けることが出来るようにしました。

* 式の生成 (2)

combine :: [Float] -> Int -> [Expr]
combine []  _ = []
combine [x] _ = [Val x]
combine xs threshold = [App op l r
                         | (op, level) <- ops,
                           level <= threshold,
                           (ls, rs) <- split xs,
                           l <- combine ls level,
                           r <- combine rs (level - 1)]

ops :: [(Op, Int)]
ops = [(Add, 3), (Sub, 3), (Mul, 2), (Div, 2), (Cat, 1)]

今度は以下のような実行結果になります。よさそうですね。

Main> combine [1,2,3] 3
[1+2*3,1+2/3,1+23,1+2+3,1-2+3,1*2+3,1/2+3,12+3,1-2*3,1-2/3,1-23,1+2-3,1-2-3,1*2-
3,1/2-3,12-3,1*23,1*2*3,1/2*3,12*3,1/23,1*2/3,1/2/3,12/3,123]

ここまで出来たら全ての式から評価結果が100になるものを抽出するだけです。

solutions :: [Float] -> [Expr]
solutions ns = [e | e <- combine ns 3, (eval e) == 100]

* 完成

最終的なプログラムは以下のようになりました。

data Op = Add | Sub | Mul | Div | Cat
data Expr = Val Float | App Op Expr Expr

instance Show Expr where
  show (Val n) = show (floor n)
  show (App Add l r) = (show l) ++ "+" ++ (show r)
  show (App Sub l r) = (show l) ++ "-" ++ (show r)
  show (App Mul l r) = (show l) ++ "*" ++ (show r)
  show (App Div l r) = (show l) ++ "/" ++ (show r)
  show (App Cat l r) = (show l) ++ (show r)

apply :: Op -> Float -> Float -> Float
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = x / y
apply Cat x y = x * 10 + y

eval :: Expr -> Float
eval (Val n) = n
eval (App o l r) = apply o (eval l) (eval r)

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

combine :: [Float] -> Int -> [Expr]
combine []  _ = []
combine [x] _ = [Val x]
combine xs threshold = [App op l r
                         | (op, level) <- ops,
                           level <= threshold,
                           (ls, rs) <- split xs,
                           l <- combine ls level,
                           r <- combine rs (level - 1)]

ops :: [(Op, Int)]
ops = [(Add, 3), (Sub, 3), (Mul, 2), (Div, 2), (Cat, 1)]

solutions :: [Float] -> [Expr]
solutions ns = [e | e <- combine ns 3, (eval e) == 100]

main :: IO()
main = putStrLn $ unlines $ map show (solutions [1,2,3,4,5,6,7,8,9])

実行結果は以下です。Lua と同じく玄箱で GHC でコンパイルしたもので 34 秒という結果でした。順序は違いますが Lua 版と同じ 101 件が見つかっています。

KURO-BOX% time ./a.out
1-2-3+4*56/7+8*9
1*2-3+4+56/7+89
1+2*3-4+56/7+89
1+23-4+56/7+8*9
1+2+3-4*5+6*7+8*9
1+2+3-45+67+8*9
1*2*3-4*5+6*7+8*9
1*2*3-45+67+8*9
1+2-3*4-5+6*7+8*9
1-2*3-4-5+6*7+8*9
1-23-4-5+6*7+89
1+2*3*4*5/6+7+8*9
1*2/3+4*5/6+7+89
1+2-3*4+5*6+7+8*9
1-2-34+56+7+8*9
1-2*3-4+5*6+7+8*9
1-23-4+5*6+7+89
1-2*3+4*5+6+7+8*9
1-23+4*5+6+7+89
1+2+3+4+5+6+7+8*9
1*2*3+4+5+6+7+8*9
1*2-3+4-5+6+7+89
1+2*3-4-5+6+7+89
1+23-4-5+6+7+8*9
1+2*3+4*5-6+7+8*9
12-3-4+5-6+7+89
1+2+3*4-5-6+7+89
12*3-4-5-6+7+8*9
1/2*3/4*56+7+8*9
1*2+34-56/7+8*9
12+3+4-56/7+89
1*23-4-56/7+89
123-45-67+89
12-3-4+5*6-7+8*9
12-3+4*5+6-7+8*9
12+3*4+5+6-7+8*9
1*2*3*4+5+6-7+8*9
1/2*34-5+6-7+89
1-2-3+45-6-7+8*9
12/3+4*5-6-7+89
1*2+34+5-6-7+8*9
12+3+4+5-6-7+89
1*23-4+5-6-7+89
12+34-5-6-7+8*9
1+234*5*6/78+9
1*23+4+56/7*8+9
1+2+3*4*5/6+78+9
12-3-4+5*6+7*8+9
12-3+4*5+6+7*8+9
12+3*4+5+6+7*8+9
1+2+3-4+5+6+78+9
1*2*3-4+5+6+78+9
1*2*3*4+5+6+7*8+9
1+2*34-56+78+9
1-2-3+45-6+7*8+9
1*2-3+4*5-6+78+9
1*2+3*4+5-6+78+9
1*2+34+5-6+7*8+9
12+3*4-5-6+78+9
12+34-5-6+7*8+9
1*2*3*4-5-6+78+9
1-2-3+4*5+67+8+9
1-2-3+45+6*7+8+9
1-2+3*4+5+67+8+9
1*2+34+5+6*7+8+9
1+2*3+4+5+67+8+9
12+3-4+5+67+8+9
12*3-4*5+67+8+9
12+34-5+6*7+8+9
12+34+5*6+7+8+9
1+23-4+56+7+8+9
1/2/3*456+7+8+9
1*23*4-56/7/8+9
1+2+3*4*56/7-8+9
1*23+4+5+67-8+9
1+2+34-5+67-8+9
1*2+34+56+7-8+9
1+23*4+5-6+7-8+9
12+3*45+6*7-89
123+4-5+67-89
1*234+5-67-8*9
1+234*5/6-7-89
1+2+34*5+6-7-8*9
1+234-56-7-8*9
12/3+4*5*6*7/8-9
1*2+3-4+5*6+78-9
12/3/4+5*6+78-9
1-2+3+45+6+7*8-9
1*2+3+4*5+6+78-9
1+23-4+5+6+78-9
1-2+3*4*5-6+7*8-9
12*3-4+5-6+78-9
1+23*4+56/7+8-9
1-2+3*4*5+6*7+8-9
1+23*4-5+6+7+8-9
123+4*5-6*7+8-9
123+45-67+8-9
123-4-5-6-7+8-9
1*2+3+45+67-8-9
12/3+4*5*6-7-8-9
1*2*34+56-7-8-9

./a.out  34.44s user 0.10s system 99% cpu 34.669 total

なお電卓のように左から順に計算する版については ops を以下で置き換えればいいのかと思います。（Cat 演算子だけは優先順位を色分けしないといけない）

ops = [(Add, 2), (Sub, 2), (Mul, 2), (Div, 2), (Cat, 1)]

[1] http://blog.so-net.ne.jp/rainyday/2007-07-16
[2] http://karetta.jp/article/blog/ll-spirit/034942
[3] http://blog.so-net.ne.jp/rainyday/2007-07-01