Haskellで10を作るゲームを解く

はじめに

切符に書かれた四つの数字を使用して10を作る有名な遊びがあります*1
目的の数字を与えられた数字と四則演算を使用して作るプログラムを書いてみました。言語は最近ハマっているHaskellを使用してみました。

構想

式を定義
→与えられた数字から式を列挙
→式を計算
→目的の数字が出たら勝利
このような流れで書きます。工夫の余地がある点は式を列挙するパートで、できるだけ重複しないで列挙したいです。例えば(3+2)*4と4*(2+3)どちらも試すのはアホです。なので次のように正規形を定義して正規形のみ列挙することにします。（与えられた数字は以下狭義単調増加に並んでいるとします）

正規形::任意の演算子について左側にある数字の最小値＜右側にある数字の最小値

例えば(1*3+2)*4は正規形ですが、(2+3*1)*4は正規形ではないです。任意の式を正規形にするためには3-2や3/2を2 [演算子] 3と書く必要があります。a - b = b $- a , a / b = b $/ a として新しい演算子を定めることで任意の式をくるくるひっくり返して正規形にすることができます。

実装

式の定義

data Equation = Number Integer | Operator String Equation Equation 

日本語で書けば式とは数字単体、もしくは一つの演算子と二つの式の組である。非常に明快です。二分木の変形ですね。

式の表示

instance Show Equation where 
    show (Number x) = show x
    show (Operator ('$':xs) a b) = "(" ++ show b ++ " " ++ xs ++" "++show a ++")"
    show (Operator xs a b) ="("++ (show a) ++" "++ xs++" " ++(show b)++")"

数字はそのまま表示し、演算子があったら括弧でくくってから左右の式の間にその演算子を書きます。$という記号がついた演算子は左右をひっくり返して表示します。

式の計算

calculate :: Equation -> Maybe Rational
calculate (Number x) = Just(x % 1)
calculate (Operator "+" a b) = (+) <$> calculate a <*> calculate b
calculate (Operator "*" a b) = (*) <$> calculate a <*> calculate b
calculate (Operator "-" a b) = (-) <$> calculate a <*> calculate b
calculate (Operator "$-" a b) = (-) <$> calculate b <*> calculate a
calculate (Operator "/" a b) 
    |calculate b /= Just 0 = (/) <$> calculate a <*> calculate b
    |otherwise = Nothing
calculate (Operator "$/" a b) 
    |calculate a /= Just 0 = (/) <$> calculate b <*> calculate a
    |otherwise = Nothing

Rationalは割り算を表す型です。数字だったらそのままにして演算子があったら左右にその演算子を適用し、$があったらひっくり返しています。割り算の失敗を表すためにMaybeモナドを用います。アプリカティブファンクターとして書いているところが個人的に綺麗で気に入っています。

式の列挙

makeEq :: [Integer] ->[Equation]
makeEq [] = []
makeEq [x] = [Number x]
makeEq (x:xs) = do
    let n = 1 + length xs
    i <-[0..(n-2)]
    ope <- ["+","*","-","$-","/","$/"]
    (ps,qs)<- combi i xs
    a <- makeEq (x:ps)
    b <- makeEq (qs)
    return (Operator ope a b)

リストモナドを用いて複数通りを列挙しています。リストの内包表記と本質的に同じものなのでリストモナドが良くわからなくても内包表記から類推すればなんとなくわかると思います。与えられた数字の一番最初は正規形の制約より必ず左側に渡します。任意に左側の数字の個数を選び、演算子を選び、先ほど決めた個数数字をチョイスして、左右に配置しています。チョイスする関数の実装は次のようなものです。

combi :: Int -> [a] -> [([a],[a])]
combi 0 xs = [([],xs)]
combi n (x:xs) 
    |length xs + 1 == n = [(x:xs,[])]
    |otherwise = [(x:ps,qs)|(ps,qs)<-combi (n-1) xs] 
        ++ [(ps,x:qs)|(ps,qs)<- combi n xs]

個数とリストを受け取って、その個数分取り出したものとその残りを全通り列挙しています。素直に再帰的に定義できていると思います。このとき順序を保っているのは重要です。常に使用する数字は最初の入力と同じ順序で並んでいるため先頭の数字を左に配置すれば正規形になるのです。

インターフェース

もう論理部分は完成しています。あとは入出力だけです。

main = forever $ do
    putStrLn "What Integer do you want to make?"
    i <- readLn ::IO Integer
    putStrLn "Input numbers like [1,2,3,4]"
    numbers <- readLn :: IO [Integer]
    let ans = headMaybe . (filter (\x -> calculate x == Just (i%1))) $ makeEq numbers
    putStrLn (show i ++" = " ++ showMaybe ans)
    putStrLn ""

実際に探索しているのはletの行だけです。headMaybeは長さゼロのリストに対してリストの先頭を取る関数を対応させたもの、showMaybeはMaybeモナドに文字列に変換する関数を対応させたものです。

headMaybe::[a] -> Maybe a
headMaybe [] = Nothing
headMaybe xs = Just (head xs) 

showMaybe ::(Show a)=> Maybe a -> String
showMaybe (Just a) = show a
showMaybe Nothing = "No Answer"

これで完成です！

テスト

難問の[1,1,5,8]を解かせてみましょう（答えを知らない人はネタバレに注意）

What Integer do you want to make?
10
Write numbers you should use like [1,2,3,4]
[1,1,5,8]
10 = (8 / (1 - (1 / 5)))

やりました！
速度としては遅延評価により答えが見つかればすぐに表示されるため、目的の数字が小さめですぐ答えが見つかるものは使用する数字が多くても大丈夫です。もしも作れない場合、使用する数字が６個を超えてくると全通り試してNoAnswerを表示するまでに非常に時間がかかってしまいます。組み合わせは爆発するものなので仕方ないですね。

感想、改善点

非常に直感的に書くことができたので非常に満足感がありました。計算式が本質的に二分木であることがここまで明示的に書けるとは想像以上に気持ち良いです。
改善点としてはまだ無駄な列挙をしている点です。入力に同じ数字がある場合は非常に無駄な探索をしてしまいます。また、結合則を無視しているため、(1+2)+3と1+(2+3)どちらも調べています。まあ速さを求めるならC++などで動的計画法を活用して書くべきである気がするのでそこまで気にしないでおいておきます。
コードの改善点がある場合ぜひ教えてください。
ソースとexeファイルを上げておきます。
findEquation - Google ドライブ

*1:[3,4,7,8] [1,1,5,8]などが難しいことで有名です