Haskell 有没有一种方法可以概括这个TrieMap代码？

下面是一个简单的Haskell程序，用于计算树上的等式：

import Control.Monad
import Control.Applicative
import Data.Maybe

data Tree = Leaf | Node Tree Tree

eqTree :: Tree -> Tree -> Maybe ()
eqTree Leaf         Leaf         = return ()
eqTree (Node l1 r1) (Node l2 r2) = eqTree l1 l2 >> eqTree r1 r2
eqTree _ _ = empty

假设您有一个树的关联列表

[（Tree，a）]

，并且希望找到给定树的条目。（我们可以将其视为类型类实例查找问题的简化版本。）天真地说，我们必须做O（n*s）工作，其中n是树的数量，s是每棵树的大小

如果我们使用trie映射来表示关联列表，我们可以做得更好：

(>.>) = flip (.)

data TreeMap a
    = TreeMap {
        tm_leaf :: Maybe a,
        tm_node :: TreeMap (TreeMap a)
      }

lookupTreeMap :: Tree -> TreeMap a -> Maybe a
lookupTreeMap Leaf       = tm_leaf
lookupTreeMap (Node l r) = tm_node >.> lookupTreeMap l >=> lookupTreeMap r

我们的查找现在只需要O（s）。这个算法是前一个算法的严格推广，因为我们可以通过创建一个singleton

TreeMap（）

，然后查看是否返回

Just（）

来测试等式。但出于实际原因，我们不希望这样做，因为这涉及到构建一个树形图，然后立即将其拆下

---

有没有办法将上面的两段代码概括为一个新函数，该函数既可以在

树上运行

也可以在

树映射上运行

？代码的结构似乎有一些相似之处，但如何将差异提取出来并不明显。

这是一个幼稚的解决方案。类

BinaryTree

描述了

Tree

s和

TreeMap

s是如何成为二叉树的

{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances #-}

class BinaryTree t a where
    leaf :: MonadPlus m => t a -> m a
    node :: MonadPlus m => (forall r. BinaryTree t r => t r -> m r) ->
                           (forall r. BinaryTree t r => t r -> m r) ->
                           t a -> m a

笨拙的

BinaryTree tr

约束和多参数类型类是必要的，因为

Tree

s没有将

a

放在它们的叶子上返回

。如果你真正的
树
更丰富，这条皱纹可能会消失

lookupTreeMap
可以用
BinaryTree
而不是
Tree
或
TreeMap

lookupTreeMap' :: BinaryTree t r => Tree -> t r -> Maybe r
lookupTreeMap' Leaf = leaf
lookupTreeMap' (Node l r) = node (lookupTreeMap' l) (lookupTreeMap' r)

TreeMap
有一个简单的
BinaryTree
实例

instance BinaryTree TreeMap a where
    leaf = maybe empty return . tm_leaf
    node kl kr = tm_node >.> kl >=> kr

instance BinaryTree Tree2 () where
    leaf (Tree2 Leaf) = return ()
    leaf _ = empty

    node kl kr (Tree2 (Node l r)) = kl (tree2 l) >> kr (tree2 r)
    node _ _ _ = empty

Tree
不能有
BinaryTree
实例，因为它的类型错误。这很容易用一个新类型来修复：

newtype Tree2 a = Tree2 {unTree2 :: Tree}

tree2 :: Tree -> Tree2 ()
tree2 = Tree2

Tree2
可以配备一个
BinaryTree
实例

instance BinaryTree TreeMap a where
    leaf = maybe empty return . tm_leaf
    node kl kr = tm_node >.> kl >=> kr

instance BinaryTree Tree2 () where
    leaf (Tree2 Leaf) = return ()
    leaf _ = empty

    node kl kr (Tree2 (Node l r)) = kl (tree2 l) >> kr (tree2 r)
    node _ _ _ = empty


我不认为上面的解决方案特别优雅，也不认为它必然会简化任何事情，除非
lookupTreeMap
的实现非常简单。作为一种渐进式的改进，我建议将
树
重构到基本函子中

data TreeF a = Leaf | Node a a

data Tree = Tree (TreeF Tree)

我们可以将问题分解为将基函子与自身匹配

-- This looks like a genaralized version of Applicative that can fail
untreeF :: MonadPlus m => TreeF (a -> m b) -> TreeF a -> m (TreeF b)
untreeF Leaf         Leaf       = return Leaf
untreeF (Node kl kr) (Node l r) = Node <$> kl l <*> kr r
untreeF _            _          = empty

并将基函子与
TreeMap
匹配

-- A reader for things that read from a TreeMap to avoid impredicative types.
data TMR m = TMR {runtmr :: forall r. TreeMap r -> m r}

-- This work is unavoidable. Something has to say how a TreeMap is related to Trees
untreemap :: MonadPlus m => TreeF (TMR m) -> TMR m
untreemap Leaf = TMR $ maybe empty return . tm_leaf
untreemap (Node kl kr) = TMR $ tm_node >.> runtmr kl >=> runtmr kr

与第一个示例一样，我们只定义遍历树一次

-- This looks suspiciously like a traversal / transform
lookupTreeMap' :: (TreeF a -> a) -> Tree -> a
lookupTreeMap' un = go
  where
    go (Tree Leaf) = un Leaf
    go (Tree (Node l r)) = un $ Node (go l) (go r)
    -- If the traversal is trivial these can be replaced by
    -- go (Tree tf) = un $ go <$> tf

编辑：我想起了一个关于对数和导数的非常有用的事实，这是我在一个朋友的沙发上发现的。可悲的是，这位朋友（已故的伟大科斯塔·图拉斯）已经不在我们身边了，但我为了纪念他，恶心地挂在另一位朋友的沙发上

让我们提醒自己尝试。（二十世纪九十年代早期，我的许多同事都在研究这些结构：拉尔夫·辛兹、托尔斯滕·阿尔滕基尔奇和彼得·汉考克在这一点上一触即发。）真正发生的是，我们在计算一种类型的指数
t
，记住
t->x
是一种书写
x
^
t
的方式

也就是说，我们希望为类型
t
配备一个函子
Expo t
，使
Expo tx
表示
t->x
。我们应该进一步期待Expo t的应用性（快速）Edit:Hancock将此类函子称为“Naperian”，因为它们有对数，并且它们的应用方式与函数相同，
pure
是K组合符，
是S。很快，
Expo t（）
必须与
（）
同构，与
常量（pure（））
和
const（）
完成（不多）工作

另一种说法是
t
是
Expo t
的对数

（我差点忘了：微积分爱好者应该检查
t
是否与
∂ （Expo t）（
。这个同构实际上可能相当有用。编辑：它非常有用，我们稍后将把它添加到
Expo
）

我们需要一些函子工具包的东西。身份函子是Zippy应用程序

data I     ::                         (* -> *) where
  I   :: x -> I x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance Applicative I where
  pure x = I x
  I f <*> I s = I (f s)

data (:*:) :: (* -> *) -> (* -> *) -> (* -> *) where
  (:*:) :: f x -> g x -> (f :*: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :*: q) where
  pure x = pure x :*: pure x
  (pf :*: qf) <*> (ps :*: qs) = (pf <*> ps) :*: (qf <*> qs)

data (:<:) :: (* -> *) -> (* -> *) -> (* -> *) where
  C :: f (g x) -> (f :<: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :<: q) where
  pure x          = C (pure (pure x))
  C pqf <*> C pqs = C (pure (<*>) <*> pqf <*> pqs)

zippy应用程序的产品非常适用于

data I     ::                         (* -> *) where
  I   :: x -> I x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance Applicative I where
  pure x = I x
  I f <*> I s = I (f s)

data (:*:) :: (* -> *) -> (* -> *) -> (* -> *) where
  (:*:) :: f x -> g x -> (f :*: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :*: q) where
  pure x = pure x :*: pure x
  (pf :*: qf) <*> (ps :*: qs) = (pf <*> ps) :*: (qf <*> qs)

data (:<:) :: (* -> *) -> (* -> *) -> (* -> *) where
  C :: f (g x) -> (f :<: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :<: q) where
  pure x          = C (pure (pure x))
  C pqf <*> C pqs = C (pure (<*>) <*> pqf <*> pqs)

快速应用程序的合成是快速应用的

data I     ::                         (* -> *) where
  I   :: x -> I x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance Applicative I where
  pure x = I x
  I f <*> I s = I (f s)

data (:*:) :: (* -> *) -> (* -> *) -> (* -> *) where
  (:*:) :: f x -> g x -> (f :*: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :*: q) where
  pure x = pure x :*: pure x
  (pf :*: qf) <*> (ps :*: qs) = (pf <*> ps) :*: (qf <*> qs)

data (:<:) :: (* -> *) -> (* -> *) -> (* -> *) where
  C :: f (g x) -> (f :<: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

instance (Applicative p, Applicative q) => Applicative (p :<: q) where
  pure x          = C (pure (pure x))
  C pqf <*> C pqs = C (pure (<*>) <*> pqf <*> pqs)

问题中的
树映射a
类型为

data TreeMap a
    = TreeMap {
        tm_leaf :: Maybe a,
        tm_node :: TreeMap (TreeMap a)
      }

正是
Expo Tree（可能是一棵）
，而
lookupTreeMap
是
flip appl

现在，考虑到
Tree
和
Tree->x
是完全不同的东西，我感到奇怪的是，希望代码“同时在这两个方面”工作。树相等性测试是查找的一种特殊情况，因为树相等性测试是作用于树的任何旧函数。然而，有一个巧合：为了测试平等性，我们必须把每棵树都变成自己的自我识别器编辑：这正是日志差异所在
是的

产生平等测试的结构是匹配的概念。像这样：

class Matching a b where
  type Matched a b :: *
  matched :: Matched a b -> (a, b)
  match   :: a -> b -> Maybe (Matched a b)

也就是说，我们期望
匹配的a b
以某种方式表示匹配的a
a
和a
b
对。我们应该能够提取出这一对（忘记它们是匹配的），并且我们应该能够获取任何一对并尝试匹配它们

毫不奇怪，我们可以为单元类型成功地实现这一点

instance Matching () () where
  type Matched () () = ()
  matched () = ((), ())
  match () () = Just ()

对于产品，我们以组件方式工作，组件不匹配是唯一的危险

instance (Matching s s', Matching t t') => Matching (s, t) (s', t') where
  type Matched (s, t) (s', t') = (Matched s s', Matched t t')
  matched (ss', tt') = ((s, t), (s', t')) where
    (s, s') = matched ss'
    (t, t') = matched tt'
  match (s, t) (s', t') = (,) <$> match s s' <*> match t t'

不幸的是，它被忽视了。道德上，对于每一个这样的
f
，我们都应该

Matched (f a) (f b) = f (Matched a b)

一个有趣的练习是，如果
（可遍历f，半压缩f）
，那么
f
上的免费monad有一个一阶统一算法。）

我想我们可以建立这样的“单例关联列表”：

mapOne :: forall a. (Tree, a) -> Expo Tree (Maybe a)
mapOne (t, a) = abst f where
  f :: Tree -> Maybe a
  f u = pure a <* match t u

……但是
Matched (f a) (f b) = f (Matched a b)

mapOne :: forall a. (Tree, a) -> Expo Tree (Maybe a)
mapOne (t, a) = abst f where
  f :: Tree -> Maybe a
  f u = pure a <* match t u

instance Monoid x => Monoid (ExpoTree x) where
  mempty = pure mempty
  mappend t u = mappend <$> t <*> u

instance Alternative m => Alternative (ExpoTree :<: m) where
  empty = C (pure empty)
  C f <|> C g = C ((<|>) <$> f <*> g)

class EXPO b => Matching a b where
  type Matched a b :: *
  matched :: Matched a b -> (a, b)
  match'  :: a -> Proxy b -> Expo b (Maybe (Matched a b))

data Proxy x = Poxy  -- I'm not on GHC 8 yet, and Simon needs a hand here

instance Matching () () where
  -- skip old stuff
  match' () (Poxy :: Proxy ()) = I (Just ())

instance (Matching s s', Matching t t') =>
    Matching (Either s t) (Either s' t') where
  -- skip old stuff
  match' (Left s) (Poxy :: Proxy (Either s' t')) =
    ((Left <$>) <$> match' s (Poxy :: Proxy s')) :*: pure Nothing
  match' (Right t) (Poxy :: Proxy (Either s' t')) =
    pure Nothing :*: ((Right <$>) <$> match' t (Poxy :: Proxy t'))

instance (Matching s s', Matching t t') => Matching (s, t) (s', t') where
  -- skip old stuff
  match' (s, t) (Poxy :: Proxy (s', t'))
    = C (more <$> match' s (Poxy :: Proxy s')) where
    more Nothing  = pure Nothing
    more (Just s) = ((,) s <$>) <$> match' t (Poxy :: Proxy t')

data K     :: * ->                    (* -> *) where
  K :: a -> K a x
  deriving (Show, Eq, Functor, Foldable, Traversable)

data (:+:) :: (* -> *) -> (* -> *) -> (* -> *) where
  Inl :: f x -> (f :+: g) x
  Inr :: g x -> (f :+: g) x
  deriving (Show, Eq, Functor, Foldable, Traversable)

class (Functor f, Functor (D f)) => Differentiable f where
  type D f :: (* -> *)
  plug :: (D f :*: I) x -> f x
  -- there should be other methods, but plug will do for now

instance Differentiable (K a) where
  type D (K a) = K Void
  plug (K bad :*: I x) = K (absurd bad)

instance Differentiable I where
  type D I = K ()
  plug (K () :*: I x) = I x

instance (Differentiable f, Differentiable g) => Differentiable (f :+: g) where
  type D (f :+: g) = D f :+: D g
  plug (Inl f' :*: I x) = Inl (plug (f' :*: I x))
  plug (Inr g' :*: I x) = Inr (plug (g' :*: I x))

instance (Differentiable f, Differentiable g) => Differentiable (f :*: g) where
  type D (f :*: g) = (D f :*: g) :+: (f :*: D g)
  plug (Inl (f' :*: g) :*: I x) = plug (f' :*: I x) :*: g
  plug (Inr (f :*: g') :*: I x) = f :*: plug (g' :*: I x)

instance (Differentiable f, Differentiable g) => Differentiable (f :<: g) where
  type D (f :<: g) = (D f :<: g) :*: D g
  plug ((C f'g :*: g') :*: I x) = C (plug (f'g :*: I (plug (g' :*: I x))))

class (Differentiable (Expo t), Applicative (Expo t)) => EXPO t where
  type Expo t :: * -> *
  appl  :: Expo t x -> t -> x
  abst  :: (t -> x) -> Expo t x
  hole  :: t -> D (Expo t) ()
  eloh  :: D (Expo t) () -> t

instance EXPO () where
  type Expo () = I
  -- skip old stuff
  hole ()     = K ()
  eloh (K ()) = ()

instance (EXPO s, EXPO t) => EXPO (Either s t) where
  type Expo (Either s t) = Expo s :*: Expo t
  hole (Left s)  = Inl (hole s  :*: pure ())
  hole (Right t) = Inr (pure () :*: hole t)
  eloh (Inl (f' :*: _)) = Left (eloh f')
  eloh (Inr (_ :*: g')) = Right (eloh g')

instance (EXPO s, EXPO t) => EXPO (s, t) where
  type Expo (s, t) = Expo s :<: Expo t
  hole (s, t) = C (const (pure ()) <$> hole s) :*: hole t
  eloh (C f' :*: g') = (eloh (const () <$> f'), eloh g')

newtype DExpoTree x = DExpoTree (D (Expo (Either () (Tree, Tree))) x)
  deriving (Show, Eq, Functor)

matchMe :: EXPO t => t -> Expo t Bool
matchMe t = plug ((const False <$> hole t) :*: I True)