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