# Haskell/Solutions/Applicative functors

## `Functor` recap

Exercises

Define instances of `Functor` for the following types:

1. A rose tree, defined as: `data Tree a = Node a [Tree a]`
2. `Either e` for a fixed `e`.
3. 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 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.

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
1. Check that the Applicative laws hold for this instance for `Maybe`
2. Write `Applicative` instances for
a. `Either e`, for a fixed `e`
b. `((->) r)`, for a fixed `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
```

The choice for the first argument when there are two `Left`s 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
1. Write a definition of `(<*>)` using `(>>=)` and `fmap`. Do not use do-notation.
2. 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
1. 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`
2. Rewrite the definition of commutativity for a `Monad`, using do-notation instead of `ap` or `liftM2`.
3. 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.)
4. What is the result of `[2,7,8] *> [3,9]`? (Try to guess without writing.)
5. Implement `(<**>)` in terms of other `Applicative` functions.
6. As we have just seen, some functors allow two legal implementations of `(<*>)` which are only different in the 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)`

1. 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.
2. 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.
3. 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 <*> 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)
```

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 = fmap (flip (\$)) t <*> B (L id) (L id)
-- Alternate definition using <**>
fructify t = t <**> B (L id) (L id)
```

The context of `fructify t` (i.e., the tree's shape) is fully determined by the context of `t`, and the values have no influence over the resulting context. That calls for `Applicative`. In the case of `AT`, `tf <*> tx` has the same shape as `tf`, except with each leaf replaced by a tree with the shape of `tx`. Hence, the desired shape for `fructify t` can be obtained by applying a tree of shape `B (L _) (L _)` to `t`. In the above definition that uses `(<*>)`, some processing is needed to get `t` as the first argument to `(<*>)`; the definition that uses `(<**>)` is more natural. `id` is used as each morphism function to produce the same value in each new leaf as that of the parent leaf.

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 `AT`s). By the way, `sagittalMap` would have the exact same implementation of `reproduce`, only using the other instance.

## The monoidal presentation

Exercises
1. Write implementations for `unit` and `(*&*)` in terms of `pure` and `(<*>)`, and vice-versa.
2. Formulate the law of commutative applicative functors (see the Sequencing of effects section) in terms of the `Monoidal` methods.
3. 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 -> (g x, f x)
```