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