# Haskell/Understanding monads/Solutions/State

## State MachineEdit

### Sequencing StepsEdit

1.

```
regularPerson, distractedPerson, hastyPerson :: TurnstileState -> ([TurnstileOutput], TurnstileState)
regularPerson s0 =
let (a1, s1) = coin s0
(a2, s2) = push s1
in ([a1, a2], s2)
distractedPerson s0 =
let (a1, s1) = coin s0
in ([a1], s1)
hastyPerson s0 =
let (a1, s1) = push s0
in if a1 == Open
then ([a1], s1)
else let (a2, s2) = coin s1
(a3, s3) = push s2
in ([a1, a2, a3], s3)
GHCi> regularPerson Locked
([Thank,Open],Locked)
GHCi> distractedPerson Locked
([Thank],Unlocked)
GHCi> hastyPerson Locked
([Tut,Thank,Open],Locked)
GHCi> hastyPerson Unlocked
([Open],Locked)
```

2.

```
tuesday :: TurnstileState -> ([TurnstileOutput], TurnstileState)
tuesday s0 =
let (ax1, s1) = regularPerson s0
(ax2, s2) = hastyPerson s1
(ax3, s3) = distractedPerson s2
(ax4, s4) = hastyPerson s3
GHCi> tuesday Locked
([Thank,Open,Tut,Thank,Open,Thank,Open],Locked) --note the second hastyPerson had a much easier time.
```

3.

```
luckyPair :: Bool -> TurnstileState -> (Bool, TurnstileState)
luckyPair firstIsDistracted s0 =
let (_, s1) = if firstIsDistracted then distractedPerson s0 else regularPerson s0
(a2, s2) = push s1
in (a2 == Open, s2)
GHCi> luckyPair False Locked
(False,Locked)
GHCi> luckyPair True Locked
(True,Locked)
```

## Turnsile using `State`

Edit

### Using the Turnstile `State`

monadEdit

1.

```
regularPersonS, distractedPersonS, hastyPersonS :: State TurnstileState [TurnstileOutput]
regularPersonS = sequence [coinS, pushS]
distractedPersonS = sequence [coinS]
hastyPersonS = do
a1 <- pushS
if a1 == Open
then return [a1]
else do
ax <- sequence [coinS, pushS]
return (a1:ax)
```

2.

```
luckyPairS :: Bool -> State TurnstileState Bool
luckyPairS firstIsDistracted = do
if firstIsDistracted then distractedPersonS else regularPersonS -- note we don't care about the return value, so don't bind it
a2 <- pushS
return (a2 == Open)
```

### Accessing the StateEdit

1.

```
coinS = do
put Unlocked
return Thank
```

2.

```
testTurnstile :: State TurnstileState Bool
testTurnstile = do
s0 <- get
--checking locking...
put Locked
check1 <- pushS
put Unlocked
check2 <- pushS
--now checking the coin...
put Locked
coinS
check3 <- get
put Unlocked
coinS
check4 <- get
--return to original state...
put s0
return (check1 == Tut && check2 == Open && check3 == Unlocked && check4 == Unlocked)
```

3.

```
modify :: (s -> s) -> State s ()
modify f = state $ \ st -> ((), f st)
gets :: (s -> a) -> State s a
gets f = state $ \ st -> (f st, st)
-- Or, some alternatives using get and put:
modify f = do st <- get; put (f st)
modify f = get >>= \ st -> put (f st)
modify f = get >>= put . f
gets f = do st <- get; return (f st)
gets f = get >>= \ st -> return (f st)
gets f = get >>= return . f
--Or (which should make more sense after reading the State is also a Functor... section later):
gets f = fmap f get
```

### Monadic Control StructuresEdit

1.

```
regularPersonS = mapM turnS [Coin, Push]
distractedPersonS = mapM turnS [Coin]
hastyPersonS = do
a1 <- pushS
if a1 == Open
then return [a1]
else do
ax <- mapM turnS [Coin, Push]
return (a1:ax)
```

2.

```
tuesdayS :: State TurnstileState [TurnstileOutput]
tuesdayS = do
ax <- sequence [regularPersonS, hastyPersonS, distractedPersonS, hastyPersonS]
return (concat ax)
```

3.

```
saveCoins :: [TurnstileInput] -> State TurnstileState Int
saveCoins inputs = do
(_, n) <- foldM maybeTurn (Nothing, 0) inputs
return n
where
maybeTurn (Just Thank, n) Coin = return (Just Thank, n+1)
maybeTurn (_, n) i = do o <- turnS i; return (Just o, n)
```

4.

```
sequenceUntil :: (a -> Bool) -> [State s a] -> State s [a]
sequenceUntil f [] = return []
sequenceUntil f (k:kx) = do
a <- k
if f a
then return [a]
else do
ax <- sequenceUntil f kx
return (a:ax)
```

5. The only change needed is the type signature:

```
sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m [a]
```

Note that `m`

has replaced `State s`

.

## Pseudo-Random NumbersEdit

### Example: Rolling DiceEdit

1. Here's a very tedious solution:

```
rollSix :: StdGen -> ([Int], StdGen)
rollSix s0 =
let (r1, s1) = randomR (1,6) s0
(r2, s2) = randomR (1,6) s1
(r3, s3) = randomR (1,6) s2
(r4, s4) = randomR (1,6) s3
(r5, s5) = randomR (1,6) s4
(r6, s6) = randomR (1,6) s5
in ([r1, r2, r3, r4, r5, r6], s6)
```

Here's a slightly better solution: do the next question first, then `rollSix = rollN 6`

.

2.

```
rollN :: Int -> StdGen -> ([Int], StdGen)
rollN n s0 =
let xs = take n $ iterate (randomR (1,6) . snd) (randomR (1,6) s0)
in (map fst xs, snd $ last xs)
```

This is at least quite short and not tedious, but it is not the easiest to understand.

### Dice with `State`

Edit

1.

```
rollSixS :: State StdGen [Int]
rollSixS = do
r1 <- rollDieS
r2 <- rollDieS
r3 <- rollDieS
r4 <- rollDieS
r5 <- rollDieS
r6 <- rollDieS
return [r1, r2, r3, r4, r5, r6]
```

Somewhat less tedious than `rollSix`

2.

```
rollNS :: Int -> State StdGen [Int]
rollNS n = replicateM n rollDieS
```

Quite a bit easier to follow that `rollN`

.

3.

```
luckyDoubleS :: State StdGen Int
luckyDoubleS = do
r1 <- rollDieS
if r1 == 6
then do
r2 <- rollDieS
return (r1+r2)
else
return r1
```

`State`

is also a `Functor`

and an `Applicative`

Edit

1.

```
{- using <$> and <*> -}
rollPairS = (,) <$> rollDieS <*> rollDieS
{- using liftA2 -}
rollPairS = liftA2 (,) rollDieS rollDieS
```

2.

```
happyDoubleS :: State StdGen Int
happyDoubleS = do
a <- rollDieS
b <- rollDieS
return $ if a == 6 then 2 * (a + b) else a + b
```

3.

```
happyDoubleS = liftA2 happy rollDieS rollDieS
where happy a b = if a == 6 then 2 * (a + b) else a + b
```

4.
We can't write `luckyDoubleS`

using just `(<$>)`

and `(<*>)`

(or `liftA2`

), since the *number of actions taken* depends on the result of the first action. (Compare this to `happyDoubleS`

, which does make some decisions based on the result of the first action, but these decisions don't include *whether* to execute the second action.)

We need to use `(>>=)`

(or do notation), but we can simplify it a little:

```
luckyDoubleS = do
r1 <- rollDieS
if r1 == 6 then fmap (+r1) rollDieS else return r1
```

5.

```
tuesdayS :: State TurnstileState [TurnstileOutput]
tuesdayS = concat <$> sequence [regularPersonS, hastyPersonS, distractedPersonS, hastyPersonS]
saveCoins :: [TurnstileInput] -> State TurnstileState Int
saveCoins = fmap snd . foldM maybeTurn (Nothing, 0)
where
maybeTurn (Just Thank, n) Coin = return (Just Thank, n+1)
maybeTurn (_, n) i = (\o -> (Just o, n)) <$> turnS i
sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m [a]
sequenceUntil f [] = return []
sequenceUntil f (k:kx) = do
a <- k
if f a
then return [a]
else (a:) <$> sequenceUntil f kx
```

6.

The type of `fmap`

, specialised to `State s`

is `fmap :: (a -> b) -> (State s) a -> (State s) b`

(although the brackets around `State s`

are usually omitted). The first parameter is a function mapping an `a`

to a `b`

. The second is a `State s a`

value, i.e. a wrapper of a state-processing step which, when executed, will give a value of type `a`

(whilst also determining a new state of type `s`

from the original). The result has to be a `State s b`

, which is just like the `State s a`

except that, when executed, instead of returning the `a`

, the `(a -> b)`

mapping is applied to the `a`

, and we get a `b`

instead. And it also has to return exactly the same updated state as the `State s a`

would.

Here goes:

```
instance Functor (State s) where
fmap f (State p) =
let p' = \s0 -> let (a, s1) = p s0
in (f a, s1)
in state p'
-- or, slightly tidied:
fmap f (State p) = state $ \s0 -> let (a, s1) = p s0 in (f a, s1)
--or, if you'd prefer to use the runState unwrapper:
fmap f sp = state $ \s0 -> let (a, s1) = runState sp s0 in (f a, s1)
--or, with a helper function and function composition:
fmap f sp = state $ first f . runState sp
where first f (x, y) = (f x, y)
```

The type of `pure`

is `pure :: a -> State s a`

. Given any value, it creates a state-processing step which, when executed, returns that very value. It also returns the original state with no changes:

```
instance Applicative (State s) where
pure x = state $ \s0 -> (x, s0)
```

The type of `(<*>)`

is `(<*>) :: State s (a -> b) -> State s a -> State s b`

. It's like `fmap`

, except that the `a -> b`

mapping function is only obtained by executing the first state processing step. And also, we have to make sure that we execute the state-processing step to get the mapping function (and a new state) before we execute the step to get the `a`

value, and make sure we thread the updated state between them.

We could do this:

```
pf <*> px = do
f <- pf
x <- px
return (f x)
```

Except that uses do notation, and hence the `Monad`

code that we're not allowed to use. So instead, we do the pre-enlightenment tedious state threading:

```
State pf <*> State px =
state $ \s0 -> let (f, s1) = pf s0
(x, s2) = px s1
in (f x, s2)
```

You may wonder how we can check we've coded these correctly. One thing we should do is check they comply with the relevant *laws*, including the Functor laws. The first states that, if we've done it right:

```
fmap id = id
```

Let's check, using our "slightly tidied" definition from above:

```
fmap id =
= \(State p) -> state $ \s0 -> let (a, s1) = p s0 in (id a, s1)
= \(State p) -> state $ \s0 -> let (a, s1) = p s0 in (a, s1)
= \(State p) -> state $ \s0 -> p s0
= \(State p) -> state p
= \(State p) -> State p
= id
```

We should also check the other (composition) law for functors, and also the laws for applicatives and monads. (I will leave that as an exercise for the reader).

Confirming they comply with the laws is a necessary to confirm they're correct, but not by itself sufficient.

### (Probably) don't `put`

or `get`

Edit

1.

```
randomElt :: [a] -> State StdGen a
randomElt l = do
g <- get
let (n, g') = randomR (0, length l - 1) g
put g'
return $ l !! n
```

2.

```
randomElt l = do
n <- state $ randomR (0, length l - 1)
return $ l !! n
```

## Handling Combined StatesEdit

1.

```
randomTurnS :: State (StdGen, TurnstileState) TurnstileOutput
randomTurnS = do
(g,t) <- get
let (i,g') = runState randomInputS g
(o,t') = runState (turnS i) t
put (g',t')
return o
```

### State-Processing a SubcomponentEdit

1.

```
processingSnd :: State b o -> State (a,b) o
processingSnd m = do
(s1,s2) <- get
let (o,s2') = runState m s2
put (s1,s2')
return o
```

2.

```
randomTurnS :: State (StdGen, TurnstileState) TurnstileOutput
randomTurnS = do
i <- processingFst randomInputS
processingSnd $ turnS i
```

### Generic Subcomponent ProcessingEdit

1.

```
processing :: Lens cmb sub -> State sub o -> State cmb o
processing l m = do
cmb <- get
let sub = view l cmb
(o,sub') = runState m sub
cmb' = set l cmb sub'
put cmb'
return o
```

2.

```
randomTurnS :: State (StdGen, TurnstileState) TurnstileOutput
randomTurnS = do
i <- processing fstL randomInputS
processing sndL $ turnS i
```