有没有办法概括这个TrieMap代码？

Question

下面是一个简单的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）。这个算法是对前一个算法的严格概括，因为我们可以通过创建单个TreeMap ()来测试相等性，然后看看我们是否返回Just ()。但是出于实际原因，我们不想这样做，因为它涉及构建一个TreeMap，然后立即将其拆除。

有没有办法将上面的两段代码概括为一个可以同时对Tree和TreeMap运行的新函数？代码的结构似乎有些相似，但如何抽象差异并不明显。

Answer 1

编辑：我记得一个关于对数和衍生物的非常有用的事实，我发现这个事实令人厌恶地挂在朋友的沙发上。可悲的是，那位朋友（已故伟大的Kostas Tourlas）不再和我们在一起了，但是我在一个不同的朋友的沙发上被恶心地挂着来纪念他。

让我们提醒自己尝试。 （很多同事在早期就开始研究这些结构：拉尔夫·欣兹，托尔斯滕·阿尔滕基希和彼得·汉考克在这方面立刻想到了。）真正发生的是我们正在计算指数类型t，记住t -> x是一种撰写x ^ t的方式。

也就是说，我们希望为t类型设置一个仿函数Expo t，使Expo t x代表t -> x。我们应该进一步期望Expo t适用（zippily）。 编辑：Hancock将这些仿函数称为“Naperian＆＃34;”，因为它们具有对数，并且它们的功能与函数相同，pure为K组合子和<*>为S. Expo t ()必须与()同构，const (pure ())和const ()执行（不多）工作。< / p>

class Applicative (Expo t) => EXPO t where
  type Expo t :: * -> *
  appl  :: Expo t x -> (t -> x)       -- trie lookup
  abst  :: (t -> x) -> Expo t x       -- trie construction

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

（我几乎忘记了：微积分的粉丝应该检查t是否与∂ (Expo t) ()同构。这种同构可能实际上非常有用。编辑：它＆＃39; s非常有用，我们稍后会将其添加到EXPO。）

我们需要一些仿函数套件。身份仿函数是zippiy applicative ...

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)

...其对数是单位类型

instance EXPO () where
  type Expo () = I
  appl (I x) () = x
  abst f        = I (f ())

zippy applicatives的产品适用于zippily ...

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)

......他们的对数是总和。

instance (EXPO s, EXPO t) => EXPO (Either s t) where
  type Expo (Either s t) = Expo s :*: Expo t
  appl (sf :*: tf) (Left s)  = appl sf s
  appl (sf :*: tf) (Right t) = appl tf t
  abst f = abst (f . Left) :*: abst (f . Right)

zippy applicatives的成分是zippily applicative ...

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)

他们的对数是产品。

instance (EXPO s, EXPO t) => EXPO (s, t) where
  type Expo (s, t) = Expo s :<: Expo t
  appl (C stf) (s, t) = appl (appl stf s) t
  abst f = C (abst $ \ s -> abst $ \ t -> f (s, t))

如果我们打开足够的东西，我们现在可以写

newtype Tree    = Tree (Either () (Tree, Tree))
  deriving (Show, Eq)
pattern Leaf     = Tree (Left ())
pattern Node l r = Tree (Right (l, r))

newtype ExpoTree x = ExpoTree (Expo (Either () (Tree, Tree)) x)
  deriving (Show, Eq, Functor, Applicative)

instance EXPO Tree where
  type Expo Tree = ExpoTree
  appl (ExpoTree f) (Tree t) = appl f t
  abst f = ExpoTree (abst (f . Tree))

问题中的TreeMap a类型是

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

完全是Expo Tree (Maybe a)，lookupTreeMap为flip appl。

现在，鉴于Tree和Tree -> x是完全不同的事情，我希望代码在两个＆＃34;上工作都很奇怪。树相等性测试是查找的一个特例，只是树相等性测试是作用于树的任何旧函数。然而，巧合巧合是：为了测试平等，我们必须将每棵树变成自己的自我识别器。 编辑，这正是log-diff iso的内容 确实

引起相等性测试的结构是匹配的一些概念。像这样：

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

也就是说，我们希望Matched a b以某种方式表示匹配的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'

总和提供了一些不匹配的可能性。

instance (Matching s s', Matching t t') =>
    Matching (Either s t) (Either s' t') where
  type Matched (Either s t) (Either s' t')
    = Either (Matched s s') (Matched t t')
  matched (Left  ss') = (Left s,  Left s')  where (s, s') = matched ss'
  matched (Right tt') = (Right t, Right t') where (t, t') = matched tt'
  match (Left s)  (Left s')  = Left  <$> match s s'
  match (Right t) (Right t') = Right <$> match t t'
  match _         _          = Nothing

有趣的是，我们现在可以像

那样轻松地获得树的相等测试

instance Matching Tree Tree where
  type Matched Tree Tree = Tree
  matched t = (t, t)
  match (Tree t1) (Tree t2) = Tree <$> match t1 t2

（顺便提一下，Functor子类捕获了匹配的概念，

class HalfZippable f where  -- "half zip" comes from Roland Backhouse
  halfZip :: (f a, f b) -> Maybe (f (a, b))

遗憾地忽略了。在道德上，对于每个f，我们应该

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

有趣的练习是显示(Traversable f, HalfZippable f)，f上的免费monad具有一阶统一算法。）

我想我们可以建立＆＃34;单身人士协会名单＆＃34;像这样：

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

我们可以尝试将它们与这个小工具结合起来，利用所有Expo t的zippiness ......

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

...但是，Monoid Maybe x instance Alternative m => Alternative (ExpoTree :<: m) where empty = C (pure empty) C f <|> C g = C ((<|>) <$> f <*> g) 实例的彻底愚蠢继续阻碍清洁设计。

我们至少可以管理

abst

一个有趣的练习是将match与Matching融合在一起，也许这就是问题的真正含义。让重构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 ()) ，

是什么新内容

pure Nothing

对于总和，我们需要标记成功的匹配，并使用辉煌的Glaswegian 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')

对于对，我们需要按顺序构建匹配，如果是，则提前退出 第一个组件失败。

abst

因此我们可以看到构造函数与其匹配器的trie之间存在连接。

家庭作业：将match'与match'融合，有效地制表整个过程。

编辑：写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) ，我们将每个子匹配器停放在对应于子结构的trie的位置。当你想到特定位置的东西时，你应该想到拉链和微积分。让我提醒你。

我们需要使用函数常量和副产品来管理选择＆＃34;其中的漏洞是＆＃34;

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

通常的微积分定律适用，其成分给出链式规则的空间解释。

Expo t

坚持EXPO是可区分的，不会伤害我们，所以让我们扩展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 类。什么是＆＃34; trie with a hole＆＃34;？它是一个缺少输出条目的特里输入。这是关键。

hole

现在，eloh和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')

单位案例并不令人兴奋，但总和案例开始显示结构：

Left

请参阅？ Right映射到左边有一个洞的特里结构; 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)

对一个trie是一个在trie里面填充的右边的trie，因此通过在左边元素的特定子块中为右边元素创建一个洞来找到特定对的洞。

对于树木，我们制作另一个包装。

False

那么，我们如何将一棵树变成它的特里识别器呢？首先，我们抓住了＃34;除了我之外的每个人＃34; trie，我们用True填写所有这些输出，然后我们为matchMe :: EXPO t => t -> Expo t Bool matchMe t = plug ((const False <$> hole t) :*: I True) 插入缺失的条目。

D f :*: I

家庭作业提示： {{1}}是一个comonad。

没有朋友！

Answer 2

这是一个天真的解决方案。课程BinaryTree描述了Tree和TreeMap都是二叉树的方式。

{-# 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 t r约束和多参数类型类只是必需的，因为Tree不会在a离开return。如果真正的Tree更丰富，这种皱纹可能会消失。

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

Tree不能拥有BinaryTree个实例，因为它的类型错误。用newtype很容易解决这个问题：

newtype Tree2 a = Tree2 {unTree2 :: Tree}

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

Tree2可以配备BinaryTree个实例。

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的实现是非平凡的。作为渐进式改进，我建议将Tree重构为基础仿函数

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

将基础仿函数与Tree s匹配，

untree :: MonadPlus m => TreeF (Tree -> m ()) -> Tree -> m () 
untree tf (Tree tf2) = untreeF tf tf2 >> return ()

并将基础仿函数与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

专门针对Tree和TreeMap的操作可以从遍历的单个定义中获得。

eqTree :: Tree -> Tree -> Maybe ()
eqTree = lookupTreeMap' untree

lookupTreeMap :: MonadPlus m => Tree -> TreeMap a -> m a
lookupTreeMap = runtmr . lookupTreeMap' untreemap