Haskellで切符問題(1)：木の生成

Haskell

http://www.ipsj.or.jp/07editj/promenade/4605.pdf より．

まずはリストから計算木へ変換するプログラム．

module Ticket where

import Char

data Term = Val Char | App Char Term Term

trees :: [Char] -> [Char] -> [Term]
trees ds os = [ t | (_,t) <- [ otree os u | u <- dtrees ds] ]
{- (_,t)のアンダースコアは二つ組の最初の項は使用しないことを示す -}

dtrees :: [Char] -> [Term]
dtrees [x] = [Val x]
dtrees ds  = concat [ joins ls rs | (ls,rs) <- [ lrs xs ys | (xs,ys) <- splits1 ds ]]

splits1 :: [Char] -> [([Char],[Char])]
splits1 [x]    = []
splits1 (x:xs) = ([x],xs) : [ (x:ys,zs) | (ys,zs) <- splits1 xs ]

lrs :: [Char] -> [Char] -> ([Term],[Term])
lrs xs ys = (dtrees xs,dtrees ys)

joins :: [Term] -> [Term] -> [Term]
joins ls rs = [ App '^' l r | l <- ls, r <- rs ]

otree :: [Char] -> Term -> ([Char],Term)
otree os (Val c)     = (os,Val c)
otree os (App _ l r) = (os'', App o' l' r') -- 
   where (o':os',l') = otree os  l          -- 定義の左辺にパターンを使用できる
         (os''  ,r') = otree os' r

instance Show Term where
  show (Val c)     = [c]
  show (App o l r) = "(" ++ show l ++ [o] ++ show r ++ ")"

splits1関数

文字列を左右に分ける関数．

Ticket> splits1 "0123"
[("0","123"),("01","23"),("012","3")]

lrs関数

左右の数字のリストから左右の部分木を構成する関数．

Ticket> lrs "01" "23"
([(0^1)],[(2^3)])
Ticket> lrs "012" "34"
([(0^(1^2)),((0^1)^2)],[(3^4)])

joins関数

joins :: [Term] -> [Term] -> [Term]
joins ls rs = [ App '^' l r | l <- ls, r <- rs ]

左右の部分木のリストから演算適用のAppノードを合成する関数．ここでは演算子は仮に'^'としている．

Ticket> joins [(Val 'a'), (Val 'b')] [(Val 'c'), (Val 'd')]
[(a^c),(a^d),(b^c),(b^d)]

dtrees関数

末端ノードに数字を配置するパス．

dtrees ds  = concat [ joins ls rs | (ls,rs) <- [ lrs xs ys | (xs,ys) <- splits1 ds ]]

入力が"0123"の場合について考える．

式 表示結果
splits "0123" [("0","123"),("01","23"),("012","3")]
lrs ("0","123") ([0],[(1^(2^3)),((1^2)^3)])
lrs ("01","23") ([(0^1)],[(2^3)])
lrs ("012","3") ([(0^(1^2)),((0^1)^2)],[3])
let x = lrs "0" "123" in joins (fst x) (snd x) [(0^(1^(2^3))),(0^((1^2)^3))]
let x = lrs "01" "23" in joins (fst x) (snd x) [((0^1)^(2^3))]
let x = lrs "012" "3" in joins (fst x) (snd x) [((0^(1^2))^3),(((0^1)^2)^3)]

型がわかりにくくなったので，deriving Showとして表示．

Ticket> let x = lrs "0" "123" in joins (fst x) (snd x)
[App '^' (Val '0') (App '^' (Val '1') (App '^' (Val '2') (Val '3'))),App '^' (Val '0') (App '^' (App '^' (Val '1') (Val '2')) (Val '3'))]
Ticket> let x = lrs "01" "23" in joins (fst x) (snd x)
[App '^' (App '^' (Val '0') (Val '1')) (App '^' (Val '2') (Val '3'))]
Ticket> let x = lrs "012" "3" in joins (fst x) (snd x)
[App '^' (App '^' (Val '0') (App '^' (Val '1') (Val '2'))) (Val '3'),App '^' (App '^' (App '^' (Val '0') (Val '1')) (Val '2')) (Val '3')]