Haskell中使用列表单子的下推自动机

我试图在Haskell中实现下推自动机（如Sipser的计算理论介绍中所述）。我有一个有效的定义：

import Data.List
import Data.Maybe(fromMaybe)

-- A Pushdown Automaton with states of type q,
-- inputs of type s, and a stack of type g
data PDA q s g = P { state :: [q]
                   , start :: q
                   , delta :: [Rule q s g]
                   -- the transition function is list of relations
                   , final :: [q]  -- list of accept states
                   }

-- rules are mappings from a (state, Maybe input, Maybe stack) to
-- a list of (state, Maybe stack)
-- Nothing represents the empty element ε
type Rule q s g = ((q, Maybe s, Maybe g), [(q, Maybe g)])

push :: Maybe a -> [a] -> [a]
push (Just x) xs = x:xs
push Nothing  xs = xs

-- returns the popped element and the stack without that element
pop :: [a] -> (Maybe a, [a])
pop (x:xs) = (Just x, xs)
pop [] = (Nothing, [])

lookup' :: Eq a => a -> [(a, [b])] -> [b]
lookup' a xs = fromMaybe [] (lookup a xs)

-- calls deltaStar with the start state and an empty stack,
-- and checks if any of the resulting states are accept states
accepts :: (Eq q, Eq s, Eq g) => PDA g s q -> [s] -> Bool
accepts p xs = any ((`elem` final p). fst) $ deltaStar (start p) (delta p) xs []

deltaStar :: (Eq q, Eq s, Eq g)
          => q  -- the current state
          -> [Rule q s g] -- delta
          -> [s] -- inputs
          -> [g] -- the stack
          -> [(q, Maybe g)]
deltaStar q rs (x:xs) st = nub . concat $
  map (\(a, b) -> deltaStar a rs xs $ push b stack)
    (lookup' (q, Just x, fst $ pop st) rs) ++
  map (\(a, b) -> deltaStar a rs (x:xs) $ push b stack)
    (lookup' (q, Nothing, fst $ pop st) rs) ++
  map (\(a, b) -> deltaStar a rs xs $ push b st)
    (lookup' (q, Just x, Nothing) rs) ++
  map (\(a, b) -> deltaStar a rs (x:xs) $ push b st)
    (lookup' (q, Nothing, Nothing) rs)
  where stack = snd $ pop st
deltaStar q rs [] st = nub $ (q, Nothing)
                           : lookup' (q, Nothing, fst $ pop st) rs
                           ++ lookup' (q, Nothing, Nothing) rs

这给了我预期的结果。然而，看着我的

deltaStar

函数，我不禁觉得必须有一种更优雅的方式来编写它。我手动检查输入或堆栈中是否有ε的转换，我认为我无法绕过，但这种使用concat和map的非确定性在我看来就像

列表

Monad。我很想能写一些像这样的东西

deltaStar q rs (x:xs) st = do
(a, b) <- lookup' (q, Just x, fst $ pop st) rs
(c, d) <- lookup' (q, Nothing, fst $ pop st) rs
(e, f) <- lookup' (q, Just x, Nothing) rs
(g, h) <- lookup' (q, Nothing, Nothing) rs
concat [ deltaStar a rs xs $ push b stack
      , deltaStar c rs (x:xs) $ push d stack
      , deltaStar e rs xs $ push f st
      , deltaStar g rs (x:xs) $ push h st]
where stack = snd $ pop st
deltaStar q rs [] st = nub $ (q, Nothing)
                           : lookup' (q, Nothing, fst $ pop st) rs
                           ++ lookup' (q, Nothing, Nothing) rs

---

在原始定义中，

（++）

分离查找，这与

[]

的非确定性解释中的选项

（）

相对应

deltaStar q rs (x:xs) st = nub . asum $
  [ do (a, b) <- lookup' (q, Just x, fst $ pop st) rs
       deltaStar a rs xs $ push b stack
  , do (a, b) <- lookup' (q, Nothing, fst $ pop st) rs
       deltaStar a rs (x:xs) $ push b stack
  , do (a, b) <- lookup' (q, Just x, Nothing) rs
       deltaStar a rs xs $ push b st
  , do (a, b) <- lookup' (q, Nothing, Nothing) rs
       deltaStar a rs (x:xs) $ push b st
  ] where stack = snd $ pop st
-- asum [a, b, c d] = a <|> b <|> c <|> d = a ++ b ++ c ++ d
--                  = concat [a, b, c, d]

deltastarqrs（x:xs）st=nub。华硕$
[do（a，b）李耀霞的回答说明了如何使用更多的类型类多态操作，但没有解决代码重复问题。在这个回答中，我说明了如何解决这个问题。主要思想是：只有两件事情是不同的，它们是独立的，即我们是否使用一个字母和我们是否从堆栈中使用。所以让我们不确定每一个都要精心挑选

（警告：未测试的代码如下。）

deltastarqrs（x:xs）st=do
（stackSymbol，st'）我还没有使用过
可选的
类型类，你能解释一下为什么它比简单地在这里使用
concat
更合适吗？这并不是一个更好的选择，主要是个人偏好。但提到它的重点是，从
[]的抽象角度来看
作为一个不确定性单子，编写这个程序需要的操作不仅仅是
（>>=）
和
返回
，而
替代方案
提供了您需要的操作。这非常好用，正是我想要做的。谢谢！
deltaStar q rs (x:xs) st = nub . asum $
  [ do (a, b) <- lookup' (q, Just x, fst $ pop st) rs
       deltaStar a rs xs $ push b stack
  , do (a, b) <- lookup' (q, Nothing, fst $ pop st) rs
       deltaStar a rs (x:xs) $ push b stack
  , do (a, b) <- lookup' (q, Just x, Nothing) rs
       deltaStar a rs xs $ push b st
  , do (a, b) <- lookup' (q, Nothing, Nothing) rs
       deltaStar a rs (x:xs) $ push b st
  ] where stack = snd $ pop st
-- asum [a, b, c d] = a <|> b <|> c <|> d = a ++ b ++ c ++ d
--                  = concat [a, b, c, d]

deltaStar q rs (x:xs) st = do
    (stackSymbol, st') <- [pop st, (Nothing, st)]
    (stringSymbol, xs') <- [(Just x, xs), (Nothing, x:xs)]
    (a, b) <- lookup' (q, stringSymbol, stackSymbol) rs
    deltaStar a rs xs' (push b st')