haskell - 重写规则的干净方法

Question

我有以下玩具语言:

module Lang where

data Op = Move Int -- Move the pointer N steps
        | Add  Int -- Add N to the value under the pointer
        | Skip     -- Skip next op if the value under the pointer is 0
        | Halt     -- End execution
        deriving (Show, Eq)

type Program = [Op]

该语言有一个有限的环绕存储单元带，以及一个指向某个单元的指针。所有单元格最初都为零。程序会重复执行，直到读取到暂停指令为止。

现在我想编写一个函数来优化给定的程序。以下是我想要执行的优化:

| Original code       | Optimization   |
|---------------------|----------------|
| Move a : Move b : x | Move (a+b) : x |
| Add  a : Add  b : x | Add  (a+b) : x |
| Move 0 : x          | x              |
| Add  0 : x          | x              |
| Skip : Skip : x : y | x : y          |
| Halt : _            | Halt           |

此外，我只能对不直接跳过之后的代码进行优化，因为这样做会改变程序的含义。

在列表上重复进行模式匹配，直到无法执行更多优化，这真的是最好/最干净的方法吗？

如果我决定也想执行更高级的重写，如下所示:

| Original code                                          | Optimization                                   |
|--------------------------------------------------------|------------------------------------------------|
| if the program begins with (Skip : a)                  | move it to the end of the program              |
| Move x ++ no_skips : Move -x ++ no_skips' : Move w : q | Move x ++ no_skips ++ no_skips' : Move w-x : q |

Answer 1

使用 Maybe 的!

@user2407038 告诉我可以在评论中使用 Maybe

module MaybeProg where

import Lang
import Control.Monad

type Opt = Program -> Maybe Program

optimize = untilFail step
  where step p | p' <- atEveryButSkipNextWhen (==Skip) rewrite
                     . atEvery   delNopSkip
                     $ untilFail moveSkips p
               , p /= p' = Just p'
               | otherwise = Nothing
        rewrite = tryAll [joinMoves, joinAdds, delNopMov, delNopAdd, termHalt, reorder]

joinMoves  p = do (Move a : Move b : x) <- pure p; Just $ Move (a+b) : x
joinAdds   p = do (Add  a : Add  b : x) <- pure p; Just $ Add  (a+b) : x
delNopMov  p = do (Move 0          : x) <- pure p; Just x
delNopAdd  p = do (Add  0          : x) <- pure p; Just x
delNopSkip p = do (Skip   : Skip   : x) <- pure p; Just x
termHalt   p = do (Halt            : _) <- pure p; Just [Halt]
moveSkips  p = do (Skip   : x : y  : z) <- pure p; Just $ y : z ++ [Skip, x]

reorder p = do
  (Move x : rst)      <- pure p
  (as, Move y : rst') <- break' isMove rst
  guard $ x == -y && all (/=Skip) as
  (bs, Move w :   q ) <- break' isMove rst'
  guard $ all (/=Skip) bs
  return $ Move x : as ++ bs ++ Move (w-x) : q
 where isMove (Move _) = True
       isMove _        = False

--------

untilFail :: Opt -> Program -> Program
untilFail o p | Just p' <- o p = untilFail o p'
              | otherwise   = p

atEvery :: Opt -> Program -> Program
atEvery o p | (x:xs) <- untilFail o p = x : atEvery o xs
            | otherwise               = []

atEveryButSkipNextWhen c o p@(h:_)
  | not $ c h
  , (x:xs) <- untilFail o p = x : atEveryButSkipNextWhen c o xs
  | (p1:p2:ps) <- p = p1:p2:atEveryButSkipNextWhen c o ps
  | otherwise = p
atEveryButSkipNextWhen _ _ [] = []

tryAll :: [Opt] -> Opt
tryAll os p = do
  Just x : _ <- pure . dropWhile (==Nothing) $ ($p) <$> os
  return x

break' f p | (x, y) <- break f p
           , not $ null y = Just (x, y)
           | otherwise = Nothing