(A1) (mx >>= return) = mx
(A2) ((return x) >>= f) = f x
(A3) ((mx >>= f) >>= g) = (mx >>= (\x -> (f x) >>= g))
(A4) (mf <*> mx) = do {f<- mf; x<- mx; return (f x)}
(>=>) :: (a -> m b) -> (b-> m c) -> (a -> mc)
f >=> g = (\x -> (f x) >>= g))
(A1) (f >=> return) = f
(A2) (return >=> f) = f
(A3) ((f >=> g) >>= h) = (f >>= (g -> h))
{-# LANGUAGE FlexibleInstances #-}
{--
Implementujemy swoją wersję monady Writer, która jest funkcjonalnie
rownoważnana implementacji w biliotekach Haskell'a
--}
module W13a where
import Control.Monad.State
import Data.List
import Data.Char
import qualified Data.Map as Map
data MyState s a = ST (s -> (a,s))
instance Functor (MyState s) where
fmap f (ST( phi)) = ST (\s-> let (x,t) = phi s in (f x, t))
instance Applicative (MyState s) where
pure x = ST (\s -> (x,s))
(ST phi) <*> (ST st) =
ST (\s -> let (f,t) = phi s; (z,r) = st t in (f z, r))
instance Monad (MyState s) where
(ST st) >>= f =
ST (\s -> let (x,t) = st s
ST phi = f x
in phi t)
-- class Monad m => MonadState s m| m -> s where
-- get :: m s -- | Return the state from the internals of the monad.
-- put :: s -> m () -- | Replace the state inside the monad.
-- state :: (s->(a,s)) -> m a
instance MonadState s (MyState s) where
get = ST (\s -> (s,s))
put s = ST (\_ -> ((),s))
state f = ST f
---------------------------------------
-- OD TEJ PORY POSLUGUJEMY SIĘ WBUDOWANĄ
-- MONADA State
---------------------------------------
type Stos = [Int]
push :: Int -> State Stos ()
push n = state (\s -> ((),n:s))
pop :: State Stos Int
pop = state (\s -> (head s,tail s))
top :: State Stos Int
top = state (\s -> (head s,s))
plus :: State Stos ()
plus = do x <- pop
y <- pop
push (x + y)
mult :: State Stos ()
mult = do x <- pop
y <- pop
push (x * y)
prog = do push 2
push 5
push 8
x<- pop
y<- pop
push (x - y)
mult
pop
-- > (runState prog) []
-----------------------------------
data Tree a = Leaf a | Node (Tree a) (Tree a)
deriving (Show)
labelTree :: Tree a -> State Int (Tree (a, Int))
labelTree (Leaf x) = do
n <- get
put (n + 1)
return (Leaf (x, n))
labelTree (Node l r) = do
l' <- labelTree l
r' <- labelTree r
return (Node l' r')
testTree = Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c'))
-- > fst $ runState (labelTree testTree) 0
{- Liniowy kongruencyjny generator liczb pseudo-losowych --}
type Seed = Int
nextInt :: State Seed Int
nextInt = do
seed <- get -- Pobierz aktualne ziarno
let newSeed = (a * seed + b) `mod` m -- Oblicz nowe ziarno (a, c, m to stałe)
put newSeed -- Zaktualizuj stan na nowe ziarno
return newSeed -- Zwróć wygenerowaną liczbę (w tym przypadku jest to nowe ziarno, ale można zwrócić coś innego)
-- Przykładowe stałe dla generatora
a = 1664525 :: Int
b = 1013904223 :: Int
m = 2^32 :: Int
initSeed = 42 :: Int
-- Generowanie jednej liczby
generateOne :: Seed -> (Int, Seed)
generateOne initialSeed = runState nextInt initialSeed
-- > fst $ generateOne initSeed
-- Generowanie wielu liczb
genMany :: Int -> State Seed [Int]
genMany 0 = return []
genMany n = do
res <- nextInt
rest<- genMany (n-1)
return (res:rest)
-- przykład użycia:
-- > (runState $ genMany 5) initSeed
-------------------------------------------
{-- Maszyna Turinga --}
type Tape = (String, Char, String) -- (lewa strona, aktualny znak, prawa strona)
data Direction = L | R deriving (Show)
type StateName = String
type Transition = ((StateName, Char), (StateName, Char, Direction))
type Program = Map.Map (StateName, Char) (StateName, Char, Direction) -- hash table
data TMState = TMState {
tape :: Tape,
currentState :: StateName
} deriving (Show)
oneStep :: Program -> State TMState Bool
oneStep prog = do
TMState (ls, ch, rs) stan <- get
case Map.lookup (stan, ch) prog of
Nothing -> return False -- brak przejścia: zatrzymaj się
Just (newState, newSym, dir) -> do
let newTape = case dir of
L -> case ls of
[] -> ([], '_', newSym:rs)
(l:ls) -> (ls, l, newSym:rs)
R -> case rs of
[] -> (ls ++ [newSym], '_', [])
(r:rs) -> (ls ++ [newSym], r, rs)
put $ TMState newTape newState
return True
runTM :: Program -> State TMState ()
runTM prog = do
continue <- oneStep prog
if continue then
runTM prog
else
return ()
simpleProgram :: Program
simpleProgram = Map.fromList [
(("start", '0'), ("start", '1', R)),
(("start", '1'), ("start", '0', R)),
(("start", '_'), ("halt", '_', R))
]
initTape :: Tape
initTape = ([], '1', "0101_") -- '_' oznacza koniec taśmy
initState :: TMState
initState =
TMState initTape "start"
--runTuring :: Program -> TMState
runTuring prog = snd $ runState (runTM prog) initState
-- > runTuring simpleProgram
--------------------------------------------
{-- Prosty model monady ograniczony tylko
do kanałow stdin i stdout
MyIO
--}
type World = ([Char],[Char]) -- (input,output)
-- podstawowe operacje wyjścia
myPutChar :: Char -> State World ()
myPutChar ch =
state ( \(inp,out) -> ((),(inp,ch:out)) )
myPutStr :: String -> State World ()
myPutStr [] = return ()
myPutStr (c:cs) = myPutChar c >> myPutStr cs
myPutStrLn cs = myPutStr cs >> myPutChar '\n'
myPrint :: Show a => a -> State World ()
myPrint x = myPutStrLn (show x)
-- podstawowe operacje wejścia
myGetChar :: State World Char
myGetChar =
state $ \(inp,out) -> if inp=="" then
('\n',("",out))
else
(head inp, (tail inp, out))
myGetLine :: State World String
myGetLine = do
c <- myGetChar
if c =='\n' then return ""
else do
str<- myGetLine
return (c:str)
myIOProg = do
myPutStr "Jak ci na imie ?"
txt <- myGetLine
myPutStrLn $ "Hello " ++ txt
-- > (runState myIOProg) ("Jacek\nCichon","")