Haskell/理解单子/解答/状态
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)
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)
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
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. 唯一需要的更改是类型签名
sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m [a]
注意 m 已替换 State s。
1. 这是一个非常繁琐的解决方案
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)
这是一个稍微好一点的解决方案：先做下一个问题，然后 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)
这至少很短，不繁琐，但并不容易理解。
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]
比 rollSix 稍微不那么繁琐
2.
rollNS :: Int -> State StdGen [Int]
rollNS n = replicateM n rollDieS
比 rollN 更容易理解。
3.
luckyDoubleS :: State StdGen Int
luckyDoubleS = do
r1 <- rollDieS
if r1 == 6
then do
r2 <- rollDieS
return (r1+r2)
else
return r1
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. 我们不能只使用 (<$>) 和 (<*>)（或 liftA2）来编写 luckyDoubleS，因为*执行的操作数*取决于第一个操作的结果。（将此与 happyDoubleS 进行比较，它确实根据第一个操作的结果做出了一些决策，但这些决策不包括*是否*执行第二个操作。）
我们需要使用 (>>=)（或 do 符号），但我们可以简化它
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.
fmap 的类型，专门用于 State s 是 fmap :: (a -> b) -> (State s) a -> (State s) b（虽然 State s 周围的括号通常省略）。第一个参数是将 a 映射到 b 的函数。第二个是一个 State s a 值，即一个状态处理步骤的包装器，它在执行时将返回一个类型为 a 的值（同时还从原始状态确定一个类型为 s 的新状态）。结果必须是一个 State s b，它与 State s a 类似，只是在执行时，它不会返回 a，而是将 (a -> b) 映射应用于 a，我们得到一个 b。而且它也必须返回与 State s a 完全相同的更新状态。
开始吧
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)
pure 的类型是 pure :: a -> State s a。对于任何给定值，它创建一个状态处理步骤，该步骤在执行时返回该值。它还会返回原始状态，没有任何更改
instance Applicative (State s) where
pure x = state $ \s0 -> (x, s0)
(<*>) 的类型是 (<*>) :: State s (a -> b) -> State s a -> State s b。它类似于 fmap，只是 a -> b 映射函数仅通过执行第一个状态处理步骤获得。而且，我们必须确保在执行步骤获取 a 值之前，我们执行状态处理步骤获取映射函数（和一个新状态），并确保我们在它们之间传递更新状态。
我们可以这样做
pf <*> px = do
f <- pf
x <- px
return (f x)
除了它使用 do 符号，因此我们不允许使用 Monad 代码。所以相反，我们做启蒙前的繁琐状态线程
State pf <*> State px =
state $ \s0 -> let (f, s1) = pf s0
(x, s2) = px s1
in (f x, s2)
你可能会想知道我们如何检查我们是否正确编码了这些。我们应该做的一件事是检查它们是否符合相关的*定律*，包括*函子定律*。第一个指出，如果我们做对了
fmap id = id
让我们检查一下，使用我们上面的“稍微整理过的”定义
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
我们还应该检查函子的其他（组合）定律，以及应用函子和单子的定律。（我将把这留给读者作为练习）。
确认它们符合定律是确认它们正确的必要条件，但本身并不充分。
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
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
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
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