有没有办法推广这个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是每棵树的大小。

我们可以做的更好，如果我们使用一个索引树图来表示我们的协会名单：

(>.>) = 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）已经不在我们身边了，但我却因在另一个朋友的沙发上恶心地挂了他而纪念他。

让我们提醒自己试一试。 （很多我的伙伴在早期的时候就在研究这些结构：Ralf Hinze，Thorsten Altenkirch和Peter Hancock在这方面立即想到了。）真正发生的是我们计算t类型的指数，记住那t -> x是一种写作方式x^t。

也就是说，我们期望装备类型t，其中函数Expo t使得Expo t x代表t -> x。我们应该进一步期望Expo t适用（zippily）。 编辑：汉考克称这种仿函数“Naperian”，因为他们有对数，而且他们以同样的方式作为功能应用性，与pure是K个组合子和<*>是S.它是立即有Expo t()必须是同构与() ，与const (pure())和​​做（不太多）的工作。

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)()这种同构性实际上可能是相当有用编辑：。这是非常有用的，稍后我们将它添加到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) 

...其对数单位类型比比applicatives的

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

产品有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) 

......和他们的对数是资金。比比applicatives的

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) 

的组合物zippily应用性...

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是相当不同的东西，它让我觉得奇怪的是希望代码在“两个”上工作。树相等性测试是查找的一个特例，只是树相等性测试是任何在树上作用的旧函数。然而巧合巧合：为了测试平等，我们必须将每棵树变成自己的自我认识者。 编辑：这正是什么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免费的单子有一阶的统一算法。）

我想我们可以打造“单身协会名单”这样的：

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 S的拉链行为...

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填写。

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

所以我们可以看到构造函数和它的匹配器的trie之间有一个连接。

作业：保险丝abst与match'，有效地制表整个过程。

编辑：编写match'，我们将每个子匹配器停放在对应于子结构的trie的位置。当你考虑特定位置的事情时，你应该考虑拉链和微积分。让我提醒你。

我们将需要函子常量和副产品来管理“孔在哪里”的选择。

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

它不会伤害我们坚持认为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 

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

看到了吗？ A 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') 

一种用于一对线索是一个左侧线索内塞了右特里结构，所以对于特定的一对孔是通过使一个孔，用于在用于左元素的特定subtrie中右侧元件找到。

对于树木，我们做了另一个包装。

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

那么，我们如何将一棵树变成其trie特征识别器？首先，我们抓住“除我之外的所有人”，然后我们用False填写所有这些输出，然后我们插入True以查找缺失的条目。

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

作业暗示：D f :*: I是comonad。

缺席的朋友！

Answer 2

这是一个天真的解决方案。类BinaryTree描述Trees和TreeMaps如何是二叉树。

{-# 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可以在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代替方面具有直接的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