User:Duplode/Applicative solutions

Functor recap

Exercises
Define instances of Functor for the following types: A rose tree, defined as: data Tree a = Node a [Tree a] Either e for a fixed e. The function type ((->) r). In this case, f a will be (r -> a)

1.

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

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

2.

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

3.

Functions have a Functor instance, and it is a quite useful one. The "wrapped" value in this case is the result produced by the function.

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

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

fmap for functions is function composition.

The Applicative class

Exercises
Check that the Applicative laws hold for this instance for Maybe Write Applicative instances for a. Either e, for a fixed e b. ((->) r), for a fixed t

1.

Warning: the proofs below are done in very small steps. We thank you for your patience.

-- 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
case u of
    Nothing  -> Nothing <*> v <*> w
    (Just g) -> Just ((.) g) <*> v <*> w
case u of
    Nothing  -> Nothing
    (Just g) -> Just ((.) g) <*> v <*> w
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing <*> w
        (Just f) -> Just ((.) g f) <*> w
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> Just ((.) g f) <*> w
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> Just (g . f) <*> w
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> Just ((g . f) x)
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> Just (g (f x))
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> pure (g (f x))
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> pure g <*> pure (f x) -- Homomorphism
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> Just g <*> pure (f x)
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> u <*> pure (f x)
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> u <*> (pure f <*> pure x) -- Homomorphism
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> u <*> (Just f <*> Just x)
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> case w of
            Nothing  -> Nothing
            (Just x) -> u <*> (v <*> w)
case u of
    Nothing  -> Nothing
    (Just g) -> case v of
        Nothing  -> Nothing
        (Just f) -> u <*> (v <*> w)
case u of
    Nothing  -> Nothing
    (Just g) -> u <*> (v <*> w)
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

The choice for the first argument when there are two Lefts is arbitrary, but matches the Data.Either implementation.

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 and (<*>) for functions are the K and S combinators of w:SKI combinator calculus respectively.

Déja vu

Exercises
Write a definition of (<*>) using (>>=) and fmap. Do not use do-notation. Implement 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

Sequencing of effects

Exercises

For the list functor, implement from scratch (that is, without using anything from Applicative or Monad directly) both (<*>) and its version with the "wrong" sequencing of effects, (<|*|>) :: Applicative f => f (a -> b) -> f a -> f b Rewrite the definition of commutativity for a Monad, using do-notation instead of ap or liftM2. Are the following applicative functors commutative? a. ZipList b. ((->) r) c. State s (Use the newtype definition from the State chapter. Hint: You may find the answer to exercise 2 of this block useful.) What is the result of [2,7,8] *> [3,9]? (Try to guess without writing.) Implement (<**>) in terms of other Applicative functions. As we have just seen, some functors allow two legal implementations of (<*>) with different sequencing of effects. Why there is not an analogous issue involving (>>=)?

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

Note how the (<*>) implementation matches exactly the general (<*>)-from-(>>=) implementation in the first exercise of the "Déja vu" section.

2.

Another pedantically slow derivation follows.

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

Two observations. Firstly, we might continue the solution by writing the binds explicitly, substituting the definitions of (>>=) and return and so forth. However, the plumbing in State is quite convoluted, making the full derivation rather mind-numbing. For that reason, we will continue, at first, in a less formal way, so that the key insights are not obscured. Secondly, we have very good reasons to suspect State is not commutative. After all, the whole point of State is threading state updates with computations which depend on that state, and there is no particular reason why the order of the state transitions shouldn't matter. Following that lead, we will, instead of attempting to prove the do-blocks are equivalent, look for a counter-example.

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

We will now perform the substitutions, while keeping track of the (result, state) pairs in each step.

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

Neither the final states nor the final results match. That is enough to show State s is not commutative.

For the sake of completeness, here is the full deduction through the Applicative instance, done in mostly point-free style. To protect our sanity, we will leave out the newtype wrapping and unwrapping.

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

The skeleton of the second list is distributed into the skeleton of the first list; the values in the first list are discarded.

5.

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

6.

Because (>>=) imposes left-to-right sequencing. In m >>= k, k builds functorial context from the values in m. The newly generated context is then combined with the preexisting context of m, which is the matrix for creating the context of the result.

Incidentally, the fact (>>=) performing left-to-right sequencing is the main reason for the convention that leads applicative operators to do the same. liftM2 and ap are implemented using (>>=), and so they also sequence effects from left to right. That means Applicative instances must follow suit if they are to be coherent with Monad ones, and at that point it becomes sensible to extend the convention to all applicative functors (even those without Monad instances) to minimise a source of confusion.

A sliding scale of power

Exercises

The next few exercises concern the following tree data structure: data AT a = L a | B (AT a) (AT a) Write Functor, Applicative and Monad instances for AT. Do not use shortcuts such as pure = return. The Applicative and Monad instances should match; in particular, (<*>) should be equivalent to ap, which follows from the Monad instance. Implement the following functions, using either the Applicative instance, the Monad one or neither of them, if neither is enough to provide a solution. Between Applicative and Monad, choose the least powerful one which is still good enough for the task. Justify your choice for each case in a few words. a. fructify :: AT a -> AT a, which grows the tree by replacing each leaf L with a branch B containing two copies of the leaf. b. prune :: a -> (a -> Bool) -> AT a -> AT a, with prune z p t replacing a branch of t with a leaf carrying the default value z whenever any of the leaves directly on it satisfies the test p. c. reproduce :: (a -> b) -> (a -> b) -> AT a -> AT b, with reproduce f g t resulting in a new tree with two modified copies of t on the root branch. The left copy is obtained by applying f to the values in t, and the same goes for g and the right copy. There is another legal instance of Applicative for AT (the reversed sequencing version of the original one doesn't count). Write it. Hint: this other instance can be used to implement sagittalMap :: (a -> b) -> (a -> b) -> AT a -> AT b which, when given a branch, maps one function over the left child tree and the other over the right child tree. (In case you are wondering, "AT" stands for "apple tree". Botanist readers, please forgive the weak metaphors.)

1.

A definition ready to be loaded in 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 <*> B tx = B (tfl <*> tx) (tfr <*> tx)

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

Note how the laws of the various classes can guide you towards the correct instances. For example, the two first cases in the definition of (<*>) follow immediately from the fmap and interchange laws of Applicative.

2a.

fructify :: AT a -> AT a
fructify t = t >>= \x -> B x x

fructify literally makes context grow out of values, and that calls for Monad. Applicative won't do, as it doesn't provide access to the leaf values.

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)

For a second time we need to change the tree structure depending on its values, so Applicative is not an option. Monad is not enough as well. There are no values in the B nodes for the second argument of (>>=) to generate context from, and there is no way to access values elsewhere in the tree while performing the monadic bind. Thus we have resorted to a plain old explicitly recursive function.

(Note that if there were values in B we might use an explicitly recursive function to tag the nodes, and then use the tags to prune the tree through the Monad interface. It would be unnecessary trouble, of course, but it might make a nice extra exercise.)

2c.

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

reproduce replaces the leaves of B (L f) (L g) with fmap f t and fmap g t. This Applicative instance is very similar to the standard "combinatorial" Applicative of lists. As the structure of the result tree depends only of the structure of t (and not of any values), Monad is clearly unnecessary.

3.

The alternative instance is:

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)

It only combines subtrees with matching positions in the tree structures. The resulting behaviour is similar to that of ZipLists, except that when the subtree shapes are different it inserts missing branches rather than removing extra ones (and it couldn't be otherwise, since there are no empty ATs). By the way, sagittalMap would have the exact same implementation of reproduce, only using the other instance.

The monoidal presentation

Exercises
Write implementations for unit and (*&*) in terms of pure and (<*>), and vice-versa. Formulate the law of commutative applicative functors (see the Sequencing of effects section) in terms of the Monoidal methods. Write from scratch Monoidal instances for: 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)

That is a beautiful presentation of the commutativity condition. an applicative functor is commutative if the only difference between u *&* v and v *&* u is the elements of the pairs within them being swapped. All else - the values of the elements and the context around them - must be the same.

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 -> (f x, g x)