Haskell/Understanding monads/Solutions/State

State Machine

Sequencing Steps

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
  in (ax1 ++ ax2 ++ ax3 ++ ax4, s4)

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

Using the Turnstile State monad

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 State

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 Structures

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 Numbers

Example: Rolling Dice

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

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

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

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 States

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 Subcomponent

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 Processing

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