haskell - 有没有办法概括这个 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

编辑 :我想起了一个关于对数和导数的非常有用的事实，这是我在一个 friend 的沙发上令人作呕的时候发现的。可悲的是，那个 friend (已故的伟大的科斯塔斯·图拉斯)不再和我们在一起，但我通过令人作呕的卡在另一个 friend 的沙发上来纪念他。

让我们提醒自己尝试。 (我的很多伙伴在 20 年代初期都在研究这些结构:Ralf Hinze、Thorsten Altenkirch 和 Peter Hancock 在这方面立即想到。)真正发生的是我们正在计算 t 类型的指数，记住t -> x 是 x ^ t 的一种写法。

也就是说，我们希望为类型 t 配备一个仿函数 Expo t 使得 Expo t x 代表 t -> x 。我们应该进一步期望 Expo t 具有应用性(zippily)。 编辑: Hancock 将此类仿函数称为“Naperian”，因为它们具有对数，并且它们的应用方式与函数相同，pure 是 K 组合子，<*> 是 S。 Expo t () 与 isomorphic_code 必须立即成为, () 和 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

另一种说法是 const () 是 t 的对数。

(我差点忘了:微积分爱好者应该检查 Expo t 是否与 t 同构。这种同构实际上可能相当有用。 编辑: 它非常有用，我们稍后会将其添加到 ∂ (Expo t) () 中。)

我们需要一些 functor kit 的东西。恒等仿函数是 zippiy 适用的...

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 的产品是zippyly applicative...

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 的组合物是 zippyly 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))

问题中的 EXPO 类型是

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

正是 TreeMap a ，其中 Expo Tree (Maybe a) 是 lookupTreeMap 。

现在，考虑到 flip appl 和 Tree 是完全不同的东西，我很奇怪希望代码“同时”工作。树相等测试是查找的一个特例，仅因为树相等测试是作用于树的任何旧函数。然而，有一个巧合:为了测试相等性，我们必须将每棵树变成自己的自我识别器。 编辑: 这正是 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)

也就是说，我们期望 Tree -> x 以某种方式表示一对匹配的 Matched a b 和 a。我们应该能够提取配对(忘记它们匹配)，并且我们应该能够获取任何配对并尝试匹配它们。

不出所料，我们可以为单位类型做到这一点，非常成功。

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

(顺便说一句，捕获匹配概念的 b 子类是

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

可悲的是被忽视了。从道德上讲，对于每个这样的 Functor ，我们应该有

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

一个有趣的练习是证明如果 f ，那么 (Traversable f, HalfZippable 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

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

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

...但是，再次， Expo t 的 Monoid 实例的完全愚蠢继续阻碍干净的设计。

我们至少可以管理

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

一个有趣的练习是将 Maybe x 与 abst 融合，也许这就是问题的真正所在。让我们重构 match 。

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

对于 Matching ，新的是

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

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

作业:将 pure Nothing 与 abst 融合，有效地将整个过程制表。

编辑: 写 match' ，我们将每个子匹配器停在与子结构对应的特里树的位置。当你想到特定位置的东西时，你应该想到 zipper 和微积分。让我提醒你。

我们需要仿函数常数和余积来管理“洞在哪里”的选择。

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

坚持 match' 是可微的不会伤害我们，所以让我们扩展 Expo t 类。什么是“有洞的尝试”？这是一个trie，它缺少可能输入之一的输出条目。这就是关键。

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

现在， EXPO 和 hole 将见证同构。

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

看？一个 eloh 被映射到一个左边有一个洞的 trie； Left 被映射到右边有一个洞的特里。

现在是产品。

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

对的 trie 是填充在左 trie 中的右 trie，因此通过为左元素的特定子树中的右元素创建一个洞，可以找到特定对的洞。

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

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

那么，我们如何将一棵树变成它的树识别器呢？首先，我们获取它的“除我之外的所有人”trie，并用 Right 填充所有这些输出，然后为缺失的条目插入 False。

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

作业提示: True 是一个comonad。

缺席的 friend !