Haskell 中的下推自动机使用 List Monad

Question

我正在尝试在 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 的非确定性对我来说看起来像 List 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 几乎总是 return []，因为当任何模式绑定失败时，整个计算将 return []。有解决办法还是我应该坚持我的定义？

我用语言 True^n False^n 测试了我的原始函数，定义如下：

langA :: PDA Int Bool Char
langA = P [1,2,3,4]
          1
          delta
          [1,4]
  where delta = [ ((1, Nothing, Nothing), [(2, Just '$')])
                , ((2, Just False, Nothing),[(2, Just '0')])
                , ((2, Just True, Just '0'), [(3, Nothing)])
                , ((3, Just True, Just '0'), [(3, Nothing)])
                , ((3, Nothing, Just '$'), [(4, Nothing)])]

Answer 1

原定义中，(++)分隔查找，对应[]非确定性解释中的选择(<|>)。

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]

Answer 2

Li-yao Xia 的回答展示了如何使用更多类型类多态操作，但没有解决代码重复问题。在这个答案中，我展示了如何解决这个问题。主要思想是：只有两件事会发生变化，而且它们是独立变化的，即我们是否消费一个字母以及我们是否从堆栈中消费。因此，让我们不确定地为每个选择！

（警告：以下是未经测试的代码。）

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')

Haskell 中的下推自动机使用 List Monad

Pushdown Automata in Haskell using the List Monad

monads

haskell

pushdown-automaton