Haskell/Solutions/Applicative functors

← 返回 Applicative functors

Functor 回顾

练习
为以下类型定义 Functor 实例 一棵玫瑰树，定义为：data Tree a = Node a [Tree a] 对于固定 e 的 Either e。 函数类型 ((->) r)。在这种情况下，f a 将是 (r -> a)

1.

instance Functor Tree where
    fmap f (Node x ts) = Node (f x) (fmap (fmap f) ts)

-- Or, with a minor style change:
instance Functor Tree where
    fmap f (Node x ts) = Node (f x) (fmap f <$> ts)

2.

instance Functor (Either e) where
    fmap f (Right x) = Right (f x)
    fmap _ l         = l

3.

函数具有 Functor 实例，这是一个非常有用的实例。在这种情况下，“包装”的值是函数产生的结果。

instance Functor ((->) r) where
    fmap g f = g . f

-- Or simply:
instance Functor ((->) r) where
    fmap = (.)

函数的 fmap 是函数组合。

Applicative 类

练习
检查此 Maybe 实例的 Applicative 定律是否成立 为以下内容编写 Applicative 实例 a. Either e，对于固定 e b. ((->) r)，对于固定 t

1.

-- Identity
pure id <*> v = v -- Target
pure id <*> v
Just id <*> v
case v of
    Nothing  -> Nothing
    (Just x) -> Just (id x)
case v of
    Nothing  -> Nothing
    (Just x) -> Just x
v -- Q.E.D

-- Homomorphism
pure f <*> pure x = pure (f x) -- Target
pure f <*> pure x
Just f <*> Just x
Just (f x)
pure (f x) -- Q.E.D

-- Interchange
u <*> pure y = pure ($ y) <*> u -- Target
u <*> pure y
u <*> Just y
case u of
    Nothing  -> Nothing
    (Just f) -> Just (f y)
case u of
    Nothing  -> Nothing
    (Just f) -> Just (($ y) f)
pure ($ y) <*> u -- Q.E.D

-- Composition
pure (.) <*> u <*> v <*> w = u <*> (v <*> w) -- Target
pure (.) <*> u <*> v <*> w
Just (.) <*> u <*> v <*> w
-- The full mechanical derivation is too tedious,
-- so we will present a streamlined solution instead.
-- If any of u, v or w is Nothing, we get Nothing on both sides.
-- Therefore, the only interesting case is:
Just (.) <*> Just g <*> Just f <*> Just x
Just ((.) g) <*> Just f <*> Just x -- Homomorphism
Just ((.) g f) <*> Just x -- Homomorphism
Just ((.) g f x) -- Homomorphism
Just ((g . f) x)
Just (g (f x))
Just g <*> Just (f x) -- Homomorphism
Just g <*> (Just f <*> Just x) -- Homomorphism
u <*> v <*> w -- Q.E.D.

2a.

instance Applicative (Either e) where
    pure x              = Right x
    (Right f) <*> (Right x) = Right (f x) 
    (Right f) <*> l         = l
    l         <*> _         = l

-- Alternatively:
instance Applicative (Either e) where
    pure          = Right
    (Right f) <*> v = fmap f v
    l         <*> _ = l

当有两个 Left 时，第一个参数的选择是任意的，但与 Data.Either 实现相匹配。

2b.

instance Applicative ((->) r) where
    pure x  = \_ -> x
    u <*> f = \r -> u r (f r)

-- Alternatively:
instance Applicative ((->) r) where
    pure    = const
    u <*> f = \r -> u r (f r)

函数的 pure 和 (<*>) 分别是 w:SKI 组合子演算 的K 和S 组合子。

似曾相识

练习
使用 (>>=) 和 fmap 编写 (<*>) 的定义。不要使用 do-notation。 实现 liftA5 :: Applicative f => (a -> b -> c -> d -> e -> k) -> f a -> f b -> f c -> f d -> f e -> f k

1.

-- The definition of ap in the chapter, with explicit binds:
u <*> v = u >>= \f -> v >>= \x -> return (f x)
-- v >>= \x -> return (f x) = liftM f v = fmap f v
u <*> v = u >>= \f -> fmap f v
-- Or, with less points:
u <*> v = u >>= flip fmap v

2.

liftA5 :: Applicative f => (a -> b -> c -> d -> e -> k)
                        -> f a -> f b -> f c -> f d -> f e -> f k
liftA5 f r s t u v = f <$> r <*> s <*> t <*> u <*> v

效果的排序

练习

对于列表函子，从头开始实现（即，不直接使用 Applicative 或 Monad 中的任何内容）(<*>) 及其具有“错误”效果排序的版本。 (<|*|>) :: Applicative f => f (a -> b) -> f a -> f b 使用 do-notation 而不是 ap 或 liftM2 重写 Monad 的交换律定义。 以下 Applicative 函子是否可交换？ a. ZipList b. ((->) r) c. State s（使用 State 章 中的 newtype 定义。提示：你可能会发现本节练习 2 的答案很有用。） [2,7,8] *> [3,9] 的结果是什么？（尝试在不编写的情况下猜出。） 用其他 Applicative 函数实现 (<**>)。 正如我们所见，一些函子允许 (<*>) 的两种合法实现，它们只是在效果排序方面有所不同。为什么没有类似的问题涉及 (>>=)？

1.

-- Draft answer:
[]     <*> _  = []
_      <*> [] = []
(f:fs) <*> xs = fmap f xs ++ (fs <*> xs)

-- Avoiding explicit recursion:
fs <*> xs = concatMap (\f -> fmap f xs) fs
-- With less points:
fs <*> xs = concatMap (flip fmap xs) fs

[] <|*|> _      = []
_  <|*|> []     = []
fs <|*|> (x:xs) = fmap ($ x) fs ++ (fs <*> xs)

fs <|*|> xs = concatMap (\x -> fmap ($ x) fs) xs
fs <|*|> xs = concatMap (flip fmap fs . flip ($)) xs

注意 (<*>) 实现如何与“似曾相识”部分第一个练习中的一般 (<*>)-from-(>>=) 实现完全匹配。

2.

另一个过分缓慢的推导如下。

-- The definition of ap in the chapter, with explicit binds:
u <*> v = u >>= \g -> v >>= \y -> return (g y)
f <$> u <*> v = f <$> u >>= \g -> v >>= \y -> return (g y) -- See [*] note below
-- For a monad, fmap f m = liftM f m = m >>= \x -> return (f x)
f <$> u <*> v = (u >>= \x -> return (f x)) >>= \g -> v >>= \y -> return (g y)
f <$> u <*> v = u >>= \x -> (\z -> return (f z)) x >>= \g -> v >>= \y -> return (g y) -- Associativity monad law
f <$> u <*> v = u >>= \x -> return (f x) >>= \g -> v >>= \y -> return (g y)
f <$> u <*> v = u >>= \x -> (return (f x) >>= (\g -> v >>= \y -> return (g y)))
f <$> u <*> v = u >>= \x -> (\g -> v >>= \y -> return (g y)) (f x) -- Left unit monad law
f <$> u <*> v = u >>= \x -> v >>= \y -> return (f x y)
-- For a monad, liftM2 f u v = liftA2 f u v = f <$> u <*> v 
liftA2 f u v = do
    x <- u
    y <- v
    return (f x y)

-- Commutativity condition:
liftA2 f u v = liftA2 (flip f) v u
-- Therefore, for a monad to be commutative this do-block...
do
    x <- u
    y <- v
    return (f x y)
-- ... must be equivalent to this one:
do
    y <- v
    x <- u
    return (f x y) -- flip f y x = f x y

-- [*] Note: in this line...
f <$> u <*> v = f <$> u >>= \g -> v >>= \y -> return (g y)
-- ... a reasonable shortcut would be eliminating the (<$>) using a let-binding:
f <$> u <*> v = u >>= \x -> let g = f x in v >>= \y -> return (g y)
-- That leads directly to the answer:
f <$> u <*> v = u >>= \x -> v >>= \y -> return (f x y) -- etc.

3a.

liftM2 f (ZipList xs) (ZipList ys) = liftM2 (flip f) (ZipList ys) (ZipList xs)
f <$> ZipList xs <*> ZipList ys = flip f <$> ZipList ys <*> ZipList xs -- Target
f <$> ZipList xs <*> ZipList ys -- LHS
ZipList (fmap f xs) <*> ZipList ys
ZipList (zipWith ($) (fmap f xs) ys)
ZipList (zipWith ($) (fmap (flip f) ys) xs)
ZipList (fmap (flip f) ys) <*> ZipList xs
flip f <$> ZipList ys <*> ZipList xs -- Q.E.D; ZipList is commutative.

3b.

liftM2 k g f = liftM2 (flip k) f g
k <$> g <*> f = flip k <$> f <*> g -- Target
k <$> g <*> f -- LHS
k . g <*> f
\r -> ((k . g) r) (f r)
\r -> k (g r) (f r)
\r -> flip k (f r) (g r)
\r -> ((flip k . f) r) (g r)
flip k . f <*> g
flip k <$> f <*> g -- Q.E.D; ((->) r) is commutative.

3c.

liftA2 f tx ty = liftA2 (flip f) ty tx

-- Given that (State s) is a monad, we can use the result from exercise 2:
liftA2 f tx ty = do
    x <- tx
    y <- ty
    return (f x y)

liftA2 (flip f) ty tx = do
    y <- ty
    x <- tx
    return (f x y)

有两个观察结果。首先，我们可以通过显式地编写绑定来继续解决方法，代入 (>>=) 和 return 的定义等等。但是，State 中的管道相当复杂，使得完整的推导相当令人头疼。因此，我们将首先以不太正式的方式继续，以便关键的见解不会被掩盖。其次，我们有充分的理由怀疑 State 不可交换。毕竟，State 的全部意义是用依赖于该状态的计算来穿插状态更新，并且没有特别的理由说明状态转换的顺序不应该重要。遵循这一思路，我们将在尝试证明 do-blocks 相等之前，寻找一个反例。

-- Assume we have some function g :: s -> s and a state s' :: s
-- In the do-blocks above, we will substitute:
tx = modify g >> get -- Equivalent to State $ \s -> (g s, g s)
ty = put s' >> get   -- Equivalent to State $ \s -> (s', s')
-- tx modifies the current state, while ty discards it.

现在我们将执行代入，同时跟踪每一步中的（结果，状态）对。

-- Assume an initial state s :: s
liftA2 f tx ty = do        -- (_         , s  )
    x <- modify g >> get   -- (g s       , g s)
    y <- put s' >> get     -- (s'        , s' )
    return (f x y)         -- (f (g s) s', s' )

liftA2 (flip f) ty tx = do -- (_          , s   )
    y <- put s' >> get     -- (s'         , s'  )
    x <- modify g >> get   -- (g s'       , g s')
    return (f x y)         -- (f (g s') s', g s')

最终状态和最终结果都不匹配。这足以证明 State s 不可交换。

为了完整起见，这里是在 Applicative 实例中完成的完整推导，主要使用无点风格。为了保护我们的理智，我们将省略 newtype 包装和解包。

-- Pretending the s -> (_, s) from State s had an actual Monad instance:
fmap f t = first f . t      -- first f = \(x, y) -> (f x, y)
t >>= k = app . first k . t -- app = uncurry ($) = \(f, x) -> f x

tg <*> tx = tg >>= flip fmap tx -- ap
tg <*> tx = app . first (flip fmap tx) . tg
tg <*> tx = app . first (\g -> first g . tx) . tg

liftA2 f tx ty = f <$> tx <*> ty
f <$> tx <*> ty -- RHS
first f . tx <*> ty
app . first (\h -> first h . ty) . first f . tx
app . first ((\h -> first h . ty) . f) . tx
app . first ((\h -> first h . ty) . \x -> f x) . tx
app . first (\x -> first (f x) . ty) . tx
\s -> app . first (\x -> first (f x) . ty) $ tx s

-- Commutativity condition:
liftA2 f tx ty = liftA2 (flip f) ty tx
-- Given some initial state s :: s, that becomes:
app . first (\x -> first (f x) . ty) $ tx s
    = app . first (\x -> first (flip f x) . tx) $ ty s

-- Proposed counter-example:
tx = \s -> (g s, g s)
ty = \_ -> (s', s')
-- (These are the same state transitions we used above.)

app . first (\x -> first (f x) . ty) $ tx s -- LHS
app . first (\x -> first (f x) . \_ -> (s', s')) $ (g s, g s)
app . first (\x -> \_ -> first (f x) $ (s', s')) $ (g s, g s)
app . first (\x -> \_ -> (f x s', s')) $ (g s, g s)
app (\_ -> (f (g s) s', s'), g s)
(f (g s) s', s')

app . first (\x -> first (flip f x) . tx) $ ty s -- RHS
app . first (\x -> first (flip f x) . \z -> (g z, g z)) $ (s', s')
app . first (\x -> \z -> first (flip f x) $ (g z, g z)) $ (s', s')
app . first (\x -> \z -> (f (g z) x, g z)) $ (s', s')
app . (\z -> (f (g z) s', g z), s')
(f (g s') s', g s') -- LHS /= RHS
-- s -> (_, s) is not commutative; therefore, State s isn't either.

4.

Prelude> [2,7,8] *> [3,9]
[3,9,3,9,3,9]

第二个列表的骨架被分配到第一个列表的骨架中；第一个列表中的值被丢弃。

5.

v <**> u = flip ($) <$> v <*> u
-- Alternatively,
v <**> u = liftA2 (flip ($)) v u

6.

因为 (>>=) 强制从左到右排序。在 m >>= k 中，k 从 m 中的值构建函子上下文。然后，新生成的上下文与 m 的预先存在的上下文相结合，该上下文是创建结果上下文的矩阵。

顺便说一下，(>>=) 执行从左到右排序的事实是导致 Applicative 运算符遵循相同排序规则的主要原因。liftM2 和 ap 使用 (>>=) 实现，因此它们也从左到右排序效果。这意味着如果 Applicative 实例要与 Monad 实例一致，它们必须遵循相同规则，此时将该约定扩展到所有 Applicative 函子（即使那些没有 Monad 实例的函子）变得合乎情理，以最大程度地减少混乱的来源。

力量的滑动尺度

练习

接下来的几个练习涉及以下树数据结构 data AT a = L a | B (AT a) (AT a) 为 AT 编写 Functor、Applicative 和 Monad 实例。不要使用诸如 pure = return 之类的快捷方式。Applicative 和 Monad 实例应匹配；特别是，(<*>) 应等效于 ap，这来自 Monad 实例。 实现以下函数，使用 Applicative 实例、Monad 实例或两者都不使用，如果两者都不足以提供解决方案。在 Applicative 和 Monad 之间，选择对任务来说最不强大的那个。在每个案例中用几句话说明你的选择。 a. fructify :: AT a -> AT a，它通过将每个叶子 L 替换为包含两个叶子副本的分支 B 来扩展树。 b. prune :: a -> (a -> Bool) -> AT a -> AT a，其中 prune z p t 将 t 的分支替换为带有默认值 z 的叶子，只要其直接上的任何叶子满足测试 p。 c. reproduce :: (a -> b) -> (a -> b) -> AT a -> AT b，其中 reproduce f g t 导致一个新树，该树在根分支上包含两个修改后的 t 副本。通过将 f 应用于 t 中的值来获得左副本，g 和右副本也是如此。 AT 有另一个合法的 Applicative 实例（原始实例的反向排序版本不算）。写出来。提示：这个其他实例可以用来实现 sagittalMap :: (a -> b) -> (a -> b) -> AT a -> AT b 当给出一个分支时，它会在左子树上映射一个函数，在右子树上映射另一个函数。 （如果你想知道，“AT”代表“苹果树”。植物学家读者，请原谅这些不恰当的比喻。）

1.

准备在 GHCi 中加载的定义

import Control.Monad

data AT a = L a | B (AT a) (AT a)
    deriving (Show)

instance Functor AT where
    fmap f t = case t of
        L x     -> L (f x)
        B tl tr -> B (fmap f tl) (fmap f tr)

instance Applicative AT where
    pure x             = L x
    L f       <*> tx   = fmap f tx
    tf        <*> L x  = fmap ($ x) tf
    B tfl tfr <*> tx   = B (tfl <*> tx) (tfr <*> tx)

instance Monad AT where
    return x = L x
    t >>= k  = case t of
        L x     -> k x
        B tl tr -> B (tl >>= k) (tr >>= k)

注意各种类的定律如何引导你找到正确的实例。例如，(<*>) 定义中的前两个案例直接来自 Applicative 的 fmap 和交换律。

2a.

fructify :: AT a -> AT a
fructify t = fmap (flip ($)) t <*> B (L id) (L id)
-- Alternate definition using <**>
fructify t = t <**> B (L id) (L id)

fructify t 的上下文（即树的形状）完全由 t 的上下文决定，值对结果上下文没有影响。这需要使用 Applicative。在 AT 的情况下，tf <*> tx 的形状与 tf 相同，只是每个叶子都被替换为一个具有 tx 形状的树。因此，可以通过将一个形状为 B (L _) (L _) 的树应用于 t 来获得 fructify t 的所需形状。在使用 (<*>) 的上述定义中，需要一些处理才能使 t 成为 (<*>) 的第一个参数；使用 (<**>) 的定义更自然。id 用作每个态射函数，以在每个新叶子上生成与父叶子上相同的值。

2b.

prune :: a -> (a -> Bool) -> AT a -> AT a
prune z p t = case t of
    L _           -> t
    B    (L x)    (L y) -> if p x || p y then L z else t
    B ll@(L x) tr       -> if p x        then L z else B ll (prune z p tr)
    B tl       lr@(L y) -> if        p y then L z else B (prune z p tl) lr
    B tl       tr       -> B (prune z p tl) (prune z p tr)

我们需要第二次根据树的值改变树的结构，所以 `Applicative` 不是一个选择。`Monad` 也不够。`B` 节点中没有值用于 `(>>=) ` 的第二个参数来生成上下文，并且在执行单子绑定时，没有办法访问树中其他位置的值。因此，我们求助于一个普通的显式递归函数。

（请注意，如果 `B` 中有值，我们可以使用一个显式递归函数来标记节点，然后使用这些标签通过 `Monad` 接口来修剪树。当然，这样做会徒增麻烦，但它可能是一个不错的额外练习。）

2c.

reproduce :: (a -> b) -> (a -> b) -> AT a -> AT b
reproduce f g t = B (L f) (L g) <*> t

reproduce 将 `B (L f) (L g)` 的叶子替换为 `fmap f t` 和 `fmap g t`。此 `Applicative` 实例与列表的标准“组合” `Applicative` 非常相似。由于结果树的结构仅取决于 `t` 的结构（而不是任何值），因此 `Monad` 明显是不必要的。

或者，可以使用 `Functor` 如下

reproduce :: (a -> b) -> (a -> b) -> AT a -> AT b
reproduce f g t = B (f <$> t) (g <$> t)

3.

替代实例是

instance Applicative AT where
    pure x                  = L x
    L f       <*> tx        = fmap f tx
    tf        <*> L x       = fmap ($ x) tf
    B tfl tfr <*> B txl txr = B (tfl <*> txl) (tfr <*> txr)

它只将树结构中匹配位置的子树组合在一起。产生的行为类似于 `ZipLists`，只是当子树形状不同时，它插入缺少的分支，而不是删除多余的分支（而且它不可能是其他方式，因为没有空 `AT`）。顺便说一句，`sagittalMap` 将拥有 `reproduce` 的完全相同的实现，只是使用另一个实例。

单子表示

练习
根据 `pure` 和 `(<*>)` 编写 `unit` 和 `(*&*)` 的实现，反之亦然。 根据 `Monoidal` 方法制定可交换应用函子的定律（参见 效果的排序 部分）。 从头开始编写 `Monoidal` 实例用于 a. ZipList b. ((->) r)

1.

unit    = pure ()
u *&* v = (,) <$> u <*> v

pure x  = const x <$> unit
u <*> v = uncurry ($) <$> (u *&* v) -- uncurry ($) = \(f, x) -> f x

2.

liftA2 f u v = f <$> u <*> v
-- Using the results of exercise 1:
liftA2 f u v = uncurry ($) <$> (f <$> u *&* v)
liftA2 f u v = uncurry ($) <$> ((f *** id) <$> (u *&* v)) -- Naturality Monoidal law
liftA2 f u v = uncurry ($) . (f *** id) <$> (u *&* v) -- 2nd functor law
liftA2 f u v = uncurry f <$> (u *&* v) -- uncurry f = \(x, y) -> f x y

-- Commutativity condition
liftA2 f u v = liftA2 (flip f) v u
uncurry f <$> (u *&* v) = uncurry (flip f) <$> (v *&* u)
uncurry f <$> (u *&* v) = uncurry f . swap <$> (v *&* u) -- swap (x, y) = (y, x)
uncurry f <$> (u *&* v) = uncurry f <$> (swap <$> (v *&* u)) -- 2nd functor law
u *&* v = swap <$> (v *&* u)

这是一种对交换条件的漂亮展示。如果 `u *&* v` 和 `v *&* u` 之间的唯一区别是它们内部的成对元素被交换，那么应用函子是可交换的。其他所有内容（元素的值及其周围的上下文）必须相同。

3a.

instance Monoidal ZipList where
    unit                          = ZipList (repeat ())
    (ZipList xs) *&* (ZipList ys) = ZipList (zipWith (,) xs ys)

-- Or simply:
instance Monoidal ZipList where
    unit                          = ZipList (repeat ())
    (ZipList xs) *&* (ZipList ys) = ZipList (zip xs ys)

3b.

instance Monoidal ((->) r) where
    unit    = const ()
    g *&* f = \x -> (g x, f x)