====== State monads ======
* inspired by [[http://brandon.si/code/the-state-monad-a-tutorial-for-the-confused/|Brandon Simmons: The State Monad: A Tutorial for the Confused?]]
===== Control.Monad.State applied, input from list =====
* inspired from [[https://wiki.haskell.org/State_Monad|]]
* example compiles warning free with
* compiler: GHC 8.10.4 using -Wall
* package: [[https://downloads.haskell.org/~ghc/latest/docs/html/libraries/mtl-2.2.2/index.html|mtl-2.2.2]]
* example:
*
import qualified Control.Monad.State as S
main :: IO ()
main =
do
print $ S.evalState (playGame "abcaaacbbcabbab") startState
print $ S.evalState playGame2 startState
-- Example use of State monad
-- applying two methods
-- 1'st method passes a string of dictionary {a,b,c} (playGame)
-- 2'nd method passes character by character in a do block (playGame2)
-- Both produce a number that is represented by a string
-- Both share function "pass" to manipulate the state according to the following rules:
-- By default the game is off, a C toggles the
-- game on and off. A 'a' gives +1 and a 'b' gives -1.
-- E.g
-- 'ab' = 0
-- 'ca' = 1
-- 'cabca' = 0
-- State = game is on or off & current score
-- = (Bool, Int)
type GameScore = Int
type GameState = (Bool, GameScore)
playGame :: String -> S.State GameState String
playGame [] =
do
(_, score) <- S.get
return (show score)
playGame (ch:rlch) =
do
pass ch
playGame rlch
pass :: Char -> S.State GameState ()
pass ch =
do
(on, score) <- S.get
case ch of
'a' | on -> S.put (on, score + 1)
'b' | on -> S.put (on, score - 1)
'c' -> S.put (not on, score)
_ -> S.put (on, score)
result :: S.State GameState String
result = S.gets result'
where
result' :: GameState -> String
result' (_,nScore) = show nScore
playGame2 :: S.State GameState String
playGame2 =
do
pass 'a'
pass 'b'
pass 'c'
pass 'a'
pass 'a'
pass 'a'
pass 'c'
pass 'b'
pass 'b'
pass 'c'
pass 'a'
pass 'b'
pass 'b'
pass 'a'
pass 'b'
r <- result
return r
startState :: GameState
startState = (False, 0)
* output:
*
"2"
"2"
===== Control.Monad.State applied =====
* inspired from [[http://dev.stephendiehl.com/fun/001_basics.html#monad-transformers|Stephen Diehl: Haskell Basics - Monad Transformers]]
* example
* which compiles
* warning free with
* compiler: GHC 8.10.4 using -Wall
* package: [[https://downloads.haskell.org/~ghc/latest/docs/html/libraries/mtl-2.2.2/index.html|mtl-2.2.2]]
* example:
*
import qualified Control.Monad.State as S (State, put, get, gets, modify, runState, execState, evalState)
-- in package mtl-2.2.2, the line above seems to be the same as "import qualified mtl-2.2.2Control.Monad.State.Lazy ..."
{-
type signatures and descriptions of functions in
Control.Monad.State
from package: mtl-2.2.2
type State s = StateT s Identity???
put :: MonadState s m => s -> m () -- set the state value
get :: MonadState s m => m s -- get the state
gets :: MonadState s m => (s -> a) -> m a -- apply a function over the state, and return the result
modify :: MonadState s m => (s -> s) -> m () -- set the state, using a modifier function
runState :: State s a -> s -> (a, s) -- Unwrap a state monad computation as a function. (The inverse of state.)
evalState :: State s a -> s -> a -- Evaluate a state computation with the given initial state and return the final value, discarding the final state.
execState :: State s a -> s -> s -- Evaluate a state computation with the given initial state and return the final state, discarding the final value.
-}
main :: IO ()
main =
do
putStrLn "test1:"
putStrLn $ " " ++ (show (S.runState test1 (Pos 0 0)))
putStrLn $ " " ++ (show (S.execState test1 (Pos 0 0)))
putStrLn $ " " ++ (show (S.evalState test1 (Pos 0 0)))
putStrLn "test2:"
putStrLn $ " " ++ (show (S.runState test2 (Pos 0 0)))
putStrLn $ " " ++ (show (S.execState test2 (Pos 0 0)))
putStrLn $ " " ++ (show (S.evalState test2 (Pos 0 0)))
putStrLn "test3:"
putStrLn $ " " ++ (show (S.evalState test3 (Pos 0 0)))
data Direction = North | East | South | West
deriving Show
data Pos = Pos { rnLat :: Integer, rnLon :: Integer }
deriving Show
go :: Direction -> S.State Pos ()
go d = S.modify (go' d)
where
go' :: Direction -> Pos -> Pos
go' North (Pos nLat nLon) = Pos (nLat + 1) nLon
go' East (Pos nLat nLon) = Pos nLat (nLon + 1)
go' South (Pos nLat nLon) = Pos (nLat - 1) nLon
go' West (Pos nLat nLon) = Pos nLat (nLon - 1)
test1 :: S.State Pos Pos
test1 = do
go North
go East
go East
go East
go South
go South
S.gets (\pos -> (Pos ((rnLat pos) + 10) ((rnLon pos) + 10)))
test2 :: S.State Pos Pos
test2 = do
go North
go East
go East
go East
go South
go South
S.gets (\pos -> (Pos ((rnLat pos) + 10) ((rnLon pos) + 10)))
test3 :: S.State Pos Pos
test3 = do
S.put (Pos 10 10) -- resets the state to (Pos 10 10)
go North
go East
go East
go East
go South
go South
S.get -- returns the state
* executes, with output:
*
test1:
(Pos {rnLat = 9, rnLon = 13},Pos {rnLat = -1, rnLon = 3})
Pos {rnLat = -1, rnLon = 3}
Pos {rnLat = 9, rnLon = 13}
test2:
(Pos {rnLat = 9, rnLon = 13},Pos {rnLat = -1, rnLon = 3})
Pos {rnLat = -1, rnLon = 3}
Pos {rnLat = 9, rnLon = 13}
test3:
Pos {rnLat = 9, rnLon = 13}
===== A Stack-based Evaluator =====
* inspired by [[https://www.cs.bu.edu/fac/snyder/cs320/Lectures/Lecture12--%20State%20Monad.pdf|Wayne Snyder: Lecture 12: State Monads]]
* example
* which compiles
* warning free with
* compiler: GHC 8.10.4 using -Wall
* package: [[https://downloads.haskell.org/~ghc/latest/docs/html/libraries/mtl-2.2.2/index.html|mtl-2.2.2]]
* example:
*
import qualified Control.Monad.State as S
-- in package mtl-2.2.2, the line above seems to be the same as "import qualified mtl-2.2.2Control.Monad.State.Lazy ..."
import Prelude hiding (div)
{-
type signatures and descriptions of functions in
Control.Monad.State
from package: mtl-2.2.2
type State s = StateT s Identity
put :: MonadState s m => s -> m () -- set the state value
get :: MonadState s m => m s -- get the state
gets :: MonadState s m => (s -> a) -> m a -- apply a function over the state, and return the result
modify :: MonadState s m => (s -> s) -> m () -- set the state, using a modifier function
runState :: State s a -> s -> (a, s) -- Unwrap a state monad computation as a function. (The inverse of state.)
evalState :: State s a -> s -> a -- Evaluate a state computation with the given initial state and return the final value, discarding the final state.
execState :: State s a -> s -> s -- Evaluate a state computation with the given initial state and return the final state, discarding the final value.
-}
main :: IO ()
main =
do
putStrLn "test1:"
putStrLn $ " " ++ (show (S.runState test1 []))
putStrLn $ " " ++ (show (S.execState test1 []))
putStrLn $ " " ++ (show (S.evalState test1 []))
push :: Double -> S.State [Double] ()
push n = S.modify (push' n)
where
push' :: Double -> [Double] -> [Double]
push' nToPush ln' = nToPush : ln'
add :: S.State [Double] ()
add = S.modify add'
where
add' :: [Double] -> [Double]
add' [] = []
add' (na:nb:rln) = (nb + na) : rln
add' (_:_) = []
sub :: S.State [Double] ()
sub = S.modify sub'
where
sub' :: [Double] -> [Double]
sub' [] = []
sub' (na:nb:rln) = (nb - na) : rln
sub' (_:_) = []
mul :: S.State [Double] ()
mul = S.modify mul'
where
mul' :: [Double] -> [Double]
mul' [] = []
mul' (na:nb:rln) = (nb * na) : rln
mul' (_:_) = []
div :: S.State [Double] ()
div = S.modify div'
where
div' :: [Double] -> [Double]
div' [] = []
div' (na:nb:rln) = (nb / na) : rln
div' (_:_) = []
result :: S.State [Double] Double
result = S.gets result'
where
result' :: [Double] -> Double
result' [] = 0
result' (n:_) = n
test1 :: S.State [Double] Double
test1 =
do -- ((3 + 5) * (7 - 11)) / 13 = 2,461...
push 3
push 5
add
push 7
push 11
sub
mul
push 13
div
r <- result
return r
* output:
*
test1:
(-2.4615384615384617,[-2.4615384615384617])
[-2.4615384615384617]
-2.4615384615384617
===== A decoder =====
* example
* to show how a decoder can be designed by using the monad ''State''
* to take symbols that influence the amount of the following reading
* compiles
* warning free with
* compiler: GHC 8.10.4 using -Wall
* package: [[https://downloads.haskell.org/~ghc/latest/docs/html/libraries/mtl-2.2.2/index.html|mtl-2.2.2]]
* code, of module ''Main'':
import qualified Control.Monad.State as S
import qualified Safer as Sfr
main :: IO ()
main =
do
-- MyData
-- + - take the next 4 characters converted to Integer -------------------------------> 4736
-- / + - take the next 3 Integer -------------------------------------------------> [
-- / / + - take the next 13 characters converted to Integer ----------------------> 7364537284958,
-- / / / + - take the next 2 characters converted to Integer -------> 12,
-- / / / / + - take the next 11 characters converted to Integer --> 123]
-- / / / / / + -take the next 11 characters converted to Double> 44543.2345
-- / / / / / /
-- v v v v v v
print ((decode "|4:4736|3:|13:7364537284958|2:12|3:123|11:44543.23456") :: (Maybe MyData))
type DecodeState = [Char] -- the remaining chars
class Decoder tValue where
decode :: DecodeState -> (Maybe tValue)
decode lch = S.evalState decodeMaybeS lch
decodeMaybeS :: S.State DecodeState (Maybe tValue)
decodeListS :: S.State DecodeState [tValue]
decodeListS =
do
nCount <- takeRepetitionCountS
liValues <- decodeNListS nCount
return liValues
decodeNListS :: Integer -> S.State DecodeState [tValue]
decodeNListS lCount
| lCount > 0 =
do
mx <- decodeMaybeS
Sfr.ifJust mx
{- then -} (\x ->
do
liValues <- decodeNListS (lCount - 1)
return (x : liValues))
{- else -} (return [])
| otherwise = return []
data MyData = MyData Integer [Integer] Double
deriving Show
instance Decoder MyData where
decodeMaybeS =
do
mn1 <- decodeMaybeS
Sfr.ifJust mn1
{- then -} (\n1 ->
do
ln2 <- decodeListS
mn3 <- decodeMaybeS
Sfr.ifJust mn3
{- then -} (\n3 -> return (Just (MyData n1 ln2 n3)))
{- else -} (return Nothing)
)
{- else -} (return Nothing)
instance Decoder Integer where
decodeMaybeS =
do
nLength <- takeRepetitionCountS
lch <- takeCharListS nLength
if (Sfr.len lch) > 0
then return (Just ((read lch) :: Integer))
else return Nothing
instance Decoder Double where
decodeMaybeS =
do
nLength <- takeRepetitionCountS
lch <- takeCharListS nLength
if (Sfr.len lch) > 0
then return (Just ((read lch) :: Double))
else return Nothing
takeRepetitionCountS :: S.State DecodeState Integer
takeRepetitionCountS =
do
mch <- takeMaybeCharS
if mch == (Just '|')
then takeRepetitionCountS'
else return 0
where
takeRepetitionCountS' :: S.State DecodeState Integer
takeRepetitionCountS' =
do
lch <- takeUntilS ':'
nCount <- pure ((read lch) :: Integer)
return nCount
takeUntilS :: Char -> S.State DecodeState [Char]
takeUntilS ch =
do
mch <- takeMaybeCharS
if mch == (Just ch)
then return []
else
Sfr.ifJust mch
{- then -} (\ch' ->
do
lch <- takeUntilS ch
return (ch' : lch))
{- else -} (return [])
eatCh :: Integer -> [Char] -> [Char]
eatCh _ [] = []
eatCh nCount lch@(_:lrch)
| nCount > 0 = eatCh (nCount - 1) lrch
| otherwise = lch
mchGet :: [Char] -> (Maybe Char)
mchGet [] = Nothing
mchGet (ch:_) = Just ch
lchGet :: Integer -> [Char] -> [Char]
lchGet _ [] = []
lchGet nCount (ch:lrch)
| nCount > 0 = ch : (lchGet (nCount - 1) lrch)
| otherwise = []
takeCharListS :: Integer -> S.State DecodeState [Char]
takeCharListS nCount =
do
lch <- S.gets (lchGet nCount)
S.modify (eatCh nCount)
return lch
takeMaybeCharS :: S.State DecodeState (Maybe Char)
takeMaybeCharS =
do
mch <- (S.gets mchGet)
if mch == Nothing
then return Nothing
else
do
S.modify (eatCh 1)
return mch
* code, of module ''Safer'':
module Safer (
len,
take,
head,
ifJust
) where
import Prelude hiding (take, head)
import qualified Data.List as Lst
len :: [a] -> Integer
len = Lst.genericLength
take :: Integer -> [a] -> [a]
take = Lst.genericTake
head :: [a] -> (Maybe a)
head [] = Nothing
head (x:_) = Just x
ifJust :: (Maybe a) -> (a -> b) -> b -> b
ifJust (Just x) then' _ = then' x
ifJust Nothing _ bDflt = bDflt
* executes, with output:
Just (MyData 4736 [7364537284958,12,123] 44543.23456)
===== ✎ =====
~~DISCUSSION~~