IFPH 練習問題 1.2.4 簡約系列の列挙 ref: http://qiita.com/items/ffd0dab664422ed2b079

ifphex010204.hs

-- | 式の定義

data Expr = Zero
          | Pred Expr
          | Succ Expr
          | Add (Expr, Expr)
  deriving (Show)

data AExpr' = AZero
            | APred AExpr
            | ASucc AExpr
            | AAdd (AExpr, AExpr)
  deriving (Show)

type AExpr = (Pos, AExpr')
type Pos   = Int

-- | 位置情報の付加
annotate :: Pos -> Expr -> (Pos, AExpr)
annotate p Zero     = (p, (p,AZero))
annotate p (Pred e) = (q, (p,APred a))
   where (q,a) = annotate (succ p) e
annotate p (Succ e) = (q, (p,ASucc a))
   where (q,a) = annotate (succ p) e
annotate p (Add (e1,e2)) = (r, (p,AAdd (e1',e2')))
   where (q,e1') = annotate (succ p) e1
         (r,e2') = annotate (succ q) e2

-- | Redexを数える
countRedexA :: AExpr -> Int
countRedexA (_,AZero)   = 0
countRedexA (_,APred e)  = case snd e of
  ASucc _ -> 1 + countRedexA e
  _       -> countRedexA e
countRedexA (_,ASucc e)  = case snd e of
  APred _ -> 1 + countRedexA e
  _       -> countRedexA e
countRedexA (_,AAdd (e1,e2)) = 1 + countRedexA e1 + countRedexA e2

-- | 1ステップの簡約(複数の結果がありうる)
reduceA :: AExpr -> [AExpr]
reduceA (_,AZero)   = []
reduceA (p,APred e) = case snd e of
  ASucc e' -> e' : map ((,) p . APred) (reduceA e)
  _        -> map ((,) p . APred) (reduceA e)
reduceA (p,ASucc e) = case snd e of
  APred e' -> e' : map ((,) p . ASucc) (reduceA e)
  _        -> map ((,) p . ASucc) (reduceA e)
reduceA (p,AAdd(e1,e2)) = case e1 of
  (_,AZero)     -> [e2]
  (q,APred e1') -> (q,APred (p,AAdd (e1',e2)))
                : (   [ (p,AAdd (x,e2)) | x <- reduceA e1 ]
                   ++ [ (p,AAdd (e1,y)) | y <- reduceA e2 ] )
  (q,ASucc e1') -> (q,ASucc (p,AAdd (e1',e2)))
                :  (  [ (p,AAdd (x,e2)) | x <- reduceA e1 ]
                   ++ [ (p,AAdd (e1,y)) | y <- reduceA e2 ] )
  _             -> (  [ (p,AAdd (x,e2)) | x <- reduceA e1 ]
                   ++ [ (p,AAdd (e1,y)) | y <- reduceA e2 ] )

-- | 簡約系列の生成
redSeqsA :: AExpr -> [[AExpr]]
redSeqsA t = case reduceA t of
  [] -> [[t]]
  ts -> concatMap (map (t:) . redSeqsA) ts

-- | 簡約系列の数
countRedSeqsA :: AExpr -> Int
countRedSeqsA =  length . redSeqsA

-- | IFPH 練習問題 1.2.4 で与えられた式
exer010204 :: Expr
exer010204 = Add(Succ(Pred(Zero)),Zero)

{-
実行例
? countRedSeqsA $ snd $ annotate 0 exer010204
3
? putStr $ unlines $ map show $ redSeqsA $ snd $ annotate 0 exer010204
[(0,AAdd ((1,ASucc (2,APred (3,AZero))),(4,AZero))),(1,ASucc (0,AAdd ((2,APred (3,AZero)),(4,AZero)))),(1,ASucc (2,APred (0,AAdd ((3,AZero),(4,AZero))))),(0,AAdd ((3,AZero),(4,AZero))),(4,AZero)]
[(0,AAdd ((1,ASucc (2,APred (3,AZero))),(4,AZero))),(1,ASucc (0,AAdd ((2,APred (3,AZero)),(4,AZero)))),(1,ASucc (2,APred (0,AAdd ((3,AZero),(4,AZero))))),(1,ASucc (2,APred (4,AZero))),(4,AZero)]
[(0,AAdd ((1,ASucc (2,APred (3,AZero))),(4,AZero))),(0,AAdd ((3,AZero),(4,AZero))),(4,AZero)]
-}