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)