18

我正在考虑解压缩操作，并意识到表达它们的一种方法是遍历Biapplicative函子。

import Data.Biapplicative

class Traversable2 t where
  traverse2 :: Biapplicative p
            => (a -> p b c) -> t a -> p (t b) (t c)

-- Note: sequence2 :: [(a,b)] -> ([a], [b])
sequence2 :: (Traversable2 t, Biapplicative p)
          => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id

instance Traversable2 [] where
  traverse2 _ [] = bipure [] []
  traverse2 f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs

在我看来，好像每个实例Traversable都可以机械地转换为Traversable2. 但是我还没有找到一种方法来实际实现traverse2using traverse，除了在列表之间进行转换，或者可能使用unsafeCoerce. 有没有很好的方法来做到这一点？

进一步的证据表明任何事情Traversable都是Traversable2：

class (Functor t, Foldable t) => Traversable2 t where
  traverse2 :: Biapplicative p
            => (a -> p b c) -> t a -> p (t b) (t c)
  default traverse2 ::
               (Biapplicative p, Generic1 t, GTraversable2 (Rep1 t))
            => (a -> p b c) -> t a -> p (t b) (t c)
  traverse2 f xs = bimap to1 to1 $ gtraverse2 f (from1 xs)

class GTraversable2 r where
  gtraverse2 :: Biapplicative p
             => (a -> p b c) -> r a -> p (r b) (r c)

instance GTraversable2 V1 where
  gtraverse2 _ x = bipure (case x of) (case x of)

instance GTraversable2 U1 where
  gtraverse2 _ _ = bipure U1 U1

instance GTraversable2 t => GTraversable2 (M1 i c t) where
  gtraverse2 f (M1 t) = bimap M1 M1 $ gtraverse2 f t

instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :*: u) where
  gtraverse2 f (t :*: u) = bimap (:*:) (:*:) (gtraverse2 f t) <<*>> gtraverse2 f u

instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :+: u) where
  gtraverse2 f (L1 t) = bimap L1 L1 (gtraverse2 f t)
  gtraverse2 f (R1 t) = bimap R1 R1 (gtraverse2 f t)

instance GTraversable2 (K1 i c) where
  gtraverse2 f (K1 x) = bipure (K1 x) (K1 x)

instance (Traversable2 f, GTraversable2 g) => GTraversable2 (f :.: g) where
  gtraverse2 f (Comp1 x) = bimap Comp1 Comp1 $ traverse2 (gtraverse2 f) x

instance Traversable2 t => GTraversable2 (Rec1 t) where
  gtraverse2 f (Rec1 xs) = bimap Rec1 Rec1 $ traverse2 f xs

instance GTraversable2 Par1 where
  gtraverse2 f (Par1 p) = bimap Par1 Par1 (f p)
4

4 回答 4

3

我想我可能有适合你的东西。（编辑：它没有，请参阅评论。）您可以定义新类型p () c并使p b ()它们成为Functor实例。

执行

这又是你的类，带有默认定义。我走的是实现的路线，sequence2因为sequenceA它看起来更简单。

class Functor t => Traversable2 t where
  {-# MINIMAL traverse2 | sequence2 #-}
  traverse2 :: Biapplicative p => (a -> p b c) -> t a -> p (t b) (t c)
  traverse2 f = sequence2 . fmap f

  sequence2 :: Biapplicative p => t (p b c) -> p (t b) (t c)
  sequence2 = traverse2 id

现在，“正确的部分”Biapplicative是

newtype R p c = R { runR :: p () c }

instance Bifunctor p => Functor (R p) where
  fmap f (R x) = R $ bimap id f x

instance Biapplicative p => Applicative (R p) where
  pure x = R (bipure () x)
  R f <*> R x =
    let f' = biliftA2 const (flip const) (bipure id ()) f
    in  R $ f' <<*>> x

mkR :: Biapplicative p => p b c -> R p c
mkR = R . biliftA2 const (flip const) (bipure () ())

sequenceR :: (Traversable t, Biapplicative p) => t (p b c) -> p () (t c)
sequenceR = runR . sequenceA . fmap mkR

与“左侧部分”大致相同。完整的代码在这个 gist中。

现在我们可以制作p (t b) ()并将p () (t c)它们重新组装成p (t b) (t c).

instance (Functor t, Traversable t) => Traversable2 t where
  sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)

我需要为该实例声明打开 FlexibleInstances 和 UndecidableInstances。此外，不知何故 ghc 想要一个 Functor 约束。

测试

我用你的实例验证了[]它给出了相同的结果：

main :: IO ()
main = do
  let xs = [(x, ord x - 97) | x <- ['a'..'g']]
  print xs
  print (sequence2 xs)
  print (sequence2' xs)

traverse2' :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]
traverse2' _ [] = bipure [] []
traverse2' f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs

sequence2' :: Biapplicative p => [p b c] -> p [b] [c]
sequence2' = traverse2' id

输出

[('a',0),('b',1),('c',2),('d',3),('e',4),('f',5),('g',6)]
("abcdefg",[0,1,2,3,4,5,6])
("abcdefg",[0,1,2,3,4,5,6])

这是一个有趣的练习！

于 2018-01-15T19:44:40.887 回答
2

以下似乎可以解决问题，利用“only” undefined。可能可遍历的定律保证这是可以的，但我没有试图证明这一点。

{-# LANGUAGE GADTs, KindSignatures, TupleSections #-}

import Data.Biapplicative

import Data.Traversable

data Bimock :: (* -> * -> *) -> * -> * where
   Bimock :: p a b -> Bimock p (a,b)
   Bimfmap :: ((a,b) -> c) -> p a b -> Bimock p c
   Bimpure :: a -> Bimock p a
   Bimapp :: Bimock p ((a,b) -> c) -> p a b -> Bimock p c

instance Functor (Bimock p) where
  fmap f (Bimock p) = Bimfmap f p
  fmap f (Bimfmap g p) = Bimfmap (f . g) p
  fmap f (Bimpure x) = Bimpure (f x)
  fmap f (Bimapp gs xs) = Bimapp (fmap (f .) gs) xs
instance Biapplicative p => Applicative (Bimock p) where
  pure = Bimpure
  Bimpure f<*>xs = fmap f xs
  fs<*>Bimpure x = fmap ($x) fs
  fs<*>Bimock p = Bimapp fs p
  Bimfmap g h<*>Bimfmap i xs = Bimfmap (\(~(a₁,a₂),~(b₁,b₂)) -> g (a₁,b₁) $ i (a₂, b₂))
                              $ bimap (,) (,) h<<*>>xs
  Bimapp g h<*>xs = fmap uncurry g <*> ((,)<$>Bimock h<*>xs)

runBimock :: Biapplicative p => Bimock p (a,b) -> p a b
runBimock (Bimock p) = p
runBimock (Bimfmap f p) = bimap (fst . f . (,undefined)) (snd . f . (undefined,)) p
runBimock (Bimpure (a,b)) = bipure a b
runBimock (Bimapp (Bimpure f) xs) = runBimock . fmap f $ Bimock xs
runBimock (Bimapp (Bimfmap h g) xs)
     = runBimock . fmap (\(~(a₂,a₁),~(b₂,b₁)) -> h (a₂,b₂) (a₁,b₁))
           . Bimock $ bimap (,) (,) g<<*>>xs
runBimock (Bimapp (Bimapp h g) xs)
     = runBimock . (fmap (\θ (~(a₂,a₁),~(b₂,b₁)) -> θ (a₂,b₂) (a₁,b₁)) h<*>)
           . Bimock $ bimap (,) (,) g<<*>>xs

traverse2 :: (Biapplicative p, Traversable t) => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f s = runBimock . fmap (\bcs->(fmap fst bcs, fmap snd bcs)) $ traverse (Bimock . f) s


sequence2 :: (Traversable t, Biapplicative p)
          => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id

即使这是安全的，如果它提供了可怕的性能，我也不会感到惊讶，因为无可辩驳的模式和二次（甚至指数？）元组树的构建。

于 2018-01-15T23:59:01.633 回答
2

缺少完整的原始答案的一些观察。

如果你有一个Biapplicative双函子，你可以用它做的就是将它应用到某个东西上，并将它分成与其两个组件同构的一对双函子。

data Helper w a b = Helper {
  left :: w a (),
  right :: w () b
}

runHelper :: forall p a b. Biapplicative p => Helper p a b -> p a b
runHelper x = biliftA2 const (flip const) (left x) (right x)

makeHelper :: (Biapplicative p)
           => p a b -> Helper p a b
makeHelper w = Helper (bimap id (const ()) w)
                      (bimap (const ()) id w)

type Separated w a b = (w a (), w () b)

可以通过将@nnnmmm 和@leftroundabout 的方法应用于fmap (makeHelper . f)结构s，消除对的需要undefined，但随后您需要使用可以解决问题的有用操作来制作Helper或替换某些类型类的方法。instance

如果你有一个Traversable结构，你可以做的是sequenceA Applicative仿函数（在这种情况下你的解决方案看起来像traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f)，你的Applicative实例构建一对t结构）或者traverse它使用一个Functor（在这种情况下你的解决方案看起来像traverse2 f = fromHelper . traverse (g . makeHelper . f) where......）。无论哪种方式，您都需要定义一个Functor实例，因为Applicative继承自Functor. 您可能会尝试构建您的Functorfrom <<*>>andbipure id id或 or bimap，或者您可能会在同一次传递中处理两个单独的变量。

不幸的是，为了使这些类型适用于该Functor实例，您必须参数化为:: p b c一种我们会非正式调用的类型:: w (b,c)，其中一个参数是 的两个参数的笛卡尔积p。Haskell 的类型系统似乎在没有非标准扩展的情况下不允许这样做，但@leftroundabout 巧妙地将这一点与Bimock类分开。用于undefined强制两个分离的函子具有相同的类型。

对于性能，您要做的就是不超过一次遍历，这会产生一个同构的对象p (t b) (t c)，然后您可以转换该对象（类似于自然法则）。因此，您希望实现traverse2而不是sequence2定义sequence2为traverse2 id，以避免遍历两次。如果你分离变量并产生与 同构的东西(p (t b) (), p () (t c))，你可以像@mmmnnn 那样重新组合它们。

在实际使用中，我怀疑您会想对问题施加一些额外的结构。您的问题使组件b和完全免费，但实际上它们通常是协变或逆变函子，可以与a而不是一起排序或遍历，甚至可能有 a或实例。cBifunctorbiliftA2BitraversableTraversable tSemigroupApplicativeMonad

一个特别有效的优化是，如果您p与 a 同构，Monoid其<>操作会产生与您的t. （这适用于列表和二叉树；Data.ByteString.Builder是具有此属性的代数类型。）在这种情况下，操作的关联性使您可以将结构转换为严格的左折叠或惰性右折叠。

这是一个很好的问题，虽然对于一般情况我没有比@leftroundabout 更好的代码，但我从工作中学到了很多东西。

于 2018-01-22T20:55:16.630 回答
1

一种稍微邪恶的方法是使用类似Magmafrom的东西lens。这似乎比 leftaroundabout 的解决方案简单得多，尽管它也不漂亮。

data Mag a b t where
  Pure :: t -> Mag a b t
  Map :: (x -> t) -> Mag a b x -> Mag a b t
  Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
  One :: a -> Mag a b b

instance Functor (Mag a b) where
  fmap = Map

instance Applicative (Mag a b) where
  pure = Pure
  (<*>) = Ap

traverse2 :: forall t a b c f. (Traversable t, Biapplicative f)
          => (a -> f b c) -> t a -> f (t b) (t c)
traverse2 f0 xs0 = go m m
  where
    m :: Mag a x (t x)
    m = traverse One xs0

    go :: forall x y. Mag a b x -> Mag a c y -> f x y
    go (Pure t) (Pure u) = bipure t u
    go (Map f x) (Map g y) = bimap f g (go x y)
    go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys
    go (One x) (One y) = f0 x
    go _ _ = error "Impossible"
于 2018-03-01T09:22:06.757 回答