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)

"2"
"2"

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

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}

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

test1:
   (-2.4615384615384617,[-2.4615384615384617])
   [-2.4615384615384617]
   -2.4615384615384617

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

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

Just (MyData 4736 [7364537284958,12,123] 44543.23456)