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
        --            +-take up to 3 Integer
        --            |  +-take the next 5 characters converted to Integer
        --            |  |     +-take the next 2 characters converted to Integer
        --            |  |     |  +-take the next 3 characters converted to Integer
        --            v  v     v  v
        print ((parse 3 "5123452123123") :: [Integer])
 
type DecodeState = (Integer, [Char]) -- the number of char to be encoded and the remaining chars
 
class Decoder tValue where
    parse :: Integer -> [Char] -> [tValue]
    parse n lch = S.evalState parseS (n, lch)
    parseS :: S.State DecodeState [tValue]
 
instance Decoder Integer where
    parseS = 
        do
            (nCount, _) <- S.get
            liValues <- parseS' nCount
            return liValues
        where
            parseS' :: Integer -> S.State DecodeState [Integer]
            parseS' lCount'
                | lCount' > 0 = 
                    do
                        miValue <- parseS''
                        liValues <- parseS' (lCount' - 1)
                        Sfr.ifJust miValue
                            {- then -} (\x -> return (x : liValues))
                            {- else -} (return [])
                | otherwise = return []
            parseS'' :: S.State DecodeState (Maybe Integer)
            parseS'' = 
                do
                    mch <- takeMaybeCharS
                    miValue <- parseS''' mch
                    return miValue
            parseS''' :: (Maybe Char) -> S.State DecodeState (Maybe Integer)
            parseS''' Nothing = return Nothing
            parseS''' (Just ch)= 
                do
                    nLength <- pure ((read [ch]) :: Integer)
                    lch <- takeCharListS nLength
                    if (Sfr.len lch) > 0
                        then return (Just ((read lch) :: Integer))
                        else return Nothing
 
eatCh :: Integer -> (Integer, [Char]) -> (Integer, [Char])
eatCh _ (n, []) = (n, [])
eatCh nCount (n, lch@(_:lrch))
    | nCount > 0 = eatCh (nCount - 1) ((n - 1), lrch)
    | otherwise  = (n, lch)
 
mchGet :: (Integer, [Char]) -> (Maybe Char)
mchGet (_, []) = Nothing
mchGet (_, (ch:_)) = Just ch
 
lchGet :: Integer -> (Integer, [Char]) -> [Char]
lchGet _ (_, []) = []
lchGet nCount (n, (ch:lrch))
    | nCount > 0 = ch : (lchGet (nCount - 1) ((n - 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
<code>
    * executes, with output:<code>
[12345,12,123]