使用State Monad的树插入

Question

我有一个树，并且插入操作的定义如“为您带来美好的Haskell！” ：

data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq) 

treeInsert :: (Ord a) => a -> Tree a -> Tree a  
treeInsert x EmptyTree = Node x EmptyTree EmptyTree
treeInsert x (Node a left right)   
    | x == a = Node x left right  
    | x < a  = Node a (treeInsert x left) right  
    | x > a  = Node a left (treeInsert x right)   

我想使用State Monad重新实现treeInsert，但是我什至不确定函数声明的外观。到目前为止，我有这个：

treeInsert :: (Ord a) => a -> Tree a -> State (Tree a) a

您将如何使用State Monad编写treeInsert？

Answer 1

警告：此答案包含破坏者。

您可以很容易地在现有treeInsert函数周围编写包装器，该包装器允许您以所需的方式使用do表示法。根据注释，有一个函数modify带有修改功能f :: s -> s，并将其转换为State s ()，这是修改状态s的“动作”。这意味着您可以编写：

stateTreeInsert :: (Ord a) => a -> State (Tree a) ()
stateTreeInsert x = modify (treeInsert x)

或更简洁地说：

stateTreeInsert :: (Ord a) => a -> State (Tree a) ()
stateTreeInsert = modify . treeInsert

然后，您可以定义一个“动作”，例如：

insertSomeStuff :: (Ord a, Num a) => State (Tree a) ()
insertSomeStuff = do
  stateTreeInsert 0
  stateTreeInsert 1
  stateTreeInsert 2

然后使用execState将其应用于特定树：

main = print $ execState insertSomeStuff EmptyTree

但是，我想您对以状态处理形式从头重新实现treeInsert更感兴趣。

问题是，这样做的“直截了​​当”的方法不是很有趣或惯用。真尴尬它看起来像这样：

awkwardTreeInsert :: (Ord a) => a -> State (Tree a) ()
awkwardTreeInsert x = do
  t <- get
  case t of
    EmptyTree -> put $ Node x EmptyTree EmptyTree
    Node a l r -> case compare x a of
      LT -> do put l                 -- replace tree with left child
               awkwardTreeInsert x   -- insert into left child
               l' <- get             -- get the answer
               put $ Node a l' r     -- overwrite with whole tree w/ updated left child
      GT -> do put r
               awkwardTreeInsert x
               r' <- get
               put $ Node a l r'
      EQ -> return ()

这里的问题是，正如我们所写，状态只能一次容纳一棵树。因此，如果我们要递归地调用该算法以将某些东西插入到分支中，则需要用其子元素之一覆盖“大树”，运行递归插入，获得答案，然后用“大树”覆盖它并替换了合适的孩子。

无论如何，其工作方式与stateTreeInsert相同，因此：

insertSomeStuff :: (Ord a, Num a) => State (Tree a) ()
insertSomeStuff = do
  awkwardTreeInsert 0
  awkwardTreeInsert 1
  awkwardTreeInsert 2

main = print $ execState insertSomeStuff EmptyTree