import Data.IORef import IO import System.IO.Unsafe import Control.Monad.State.Lazy import System.Random main = putChar 'x' echo :: IO () echo = getChar >>= putChar echoDup :: IO () echoDup = getChar >>= \c -> putChar c >>= \() -> putChar c echoDup' :: IO () echoDup' = getChar >>= \c -> putChar c >> putChar c -- Recall that putChar :: Char -> IO () -- We want to return (c1,c2) inside of IO monad. -- Haskell provides "return" function for this purpose: -- return :: a -> IO a getTwoChars :: IO(Char,Char) getTwoChars = getChar >>= \c1 -> getChar >>= \c2 -> return (c1,c2) -- getLine is defined in Standard Prelude, so rename to getLine' getLine' :: IO [Char] getLine' = getChar >>= \c -> if c == '\n' then return [] else getLine' >>= \cs -> return (c:cs) -- Exercise putLine :: [Char] -> IO () putLine [] = putChar '\n' putLine (x:xs) = putChar x >> putLine xs -- End exercise echoRLine :: IO () echoRLine = getLine >>= \cs -> putLine (reverse cs) getTwoChars' :: IO(Char,Char) getTwoChars' = do { c1 <- getChar; c2 <- getChar; return (c1,c2)} -- LI: discuss types of various pieces of do notation -- Note that the following code shows that: -- 1) Each c on the left of <- is distinct -- 2) Scope of x in x <- e does not include e getCharAndReturn :: IO() getCharAndReturn = do {c <- getChar; -- c :: Char c <- putChar c; -- c :: () return c} -- Note the nested do notation. getLine'' :: IO [Char] getLine'' = do { c <- getChar; if c == '\n' then return [] else do { cs <- getLine''; return (c:cs)}} -- Web server intentionally goes into an infinite loop -- awaiting service requests. We can express this action -- using the function forever. forever' :: IO () -> IO () forever' a = a >> forever' a repeatN :: Int -> IO () -> IO () repeatN 0 a = return () repeatN n a = a >> repeatN (n-1) a -- Example invocations -- repeatN 2 echoRLine -- repeatN 10 (putChar 'x') -- Idea: (for ns fbody) will apply the function fbody to each element of -- ns in turn, in each case giving an action; these actions are combined -- in sequence using the >> combinator. -- fbody is like the body of a for loop, except it is written as a function -- from the index of the for loop to the actual body. for :: [a] -> (a -> IO b) -> IO () for [] fa = return () for (n:ns) fa = fa n >> for ns fa --Example invocation -- printNums = for [1..10] print -- LI: printChars = for ['a'..'d'] print -- (map fa ns) yields a list of actions -- sequence_ performs the actions in sequence, throwing away the intermediate results for' ns fa = sequence_ (map fa ns) -- LI: the type of sequence is actually -- sequence :: (Monad m) => [m a] -> m [a] -- show use of type classes. sequence' :: [IO a] -> IO [a] sequence' [] = return [] sequence' (a:as) = do {r <- a; rs <- sequence' as; return (r:rs)} -- Exercise: write a for loop where the body is executed only if the index -- satisfies a predicate forPred :: [a] -> (a -> Bool) -> (a -> IO a1) -> IO () forPred ns p fa = sequence_ (map fa (filter p ns)) -- forPred [1..10] even print -- forPred ['A'..'z'] Char.isUpper print forStep [] step fa = return () forStep (n:ns) step fa = forPred (n:ns) (\i->i `mod` step == n `mod` step) fa -- Exercise: Write until loop until' :: (a -> Bool) -> a -> (a -> IO a) -> IO () until' p prev body = do {r <- body prev; if p r then return () else until' p r body} -- until' (\x->x>10) 0 (\x->do {print x; return (x+1)}) -- Exercise: How modify to be while loop while' :: (Monad t) => t Bool -> t t1 -> t () while' b m = do x <- b if x then return () else do m while' b m while :: (a -> Bool) -> a -> (a -> IO a) -> IO () while p prev body = if p prev then return () else do {r <- body prev; while p r body} mapM' :: (Monad m) => (t -> m a) -> [t] -> m [a] mapM' f [] = return [] mapM' f (m:ms) = do x <- f m xs <- mapM' f ms return (x: xs) -- while (\x->x>10) 0 (\x->do {print x; return (x+1)}) count :: Int -> IO Int count n = do { r <- newIORef 0; loop r 1} where loop :: IORef Int -> Int -> IO Int loop r i | i>n = readIORef r | otherwise = do {v <- readIORef r; writeIORef r (v+i); loop r (i+1)} type HandleC = (Handle, IORef Int) openFileC :: String -> IOMode -> IO HandleC openFileC fn mode = do{ h <- openFile fn mode; v <- newIORef 0; return (h,v)} hPutStrC :: HandleC -> String -> IO() hPutStrC (h,r) cs = do {v <- readIORef r; writeIORef r (v + length cs); hPutStr h cs} hGetLineC :: HandleC -> IO [Char] hGetLineC (h,r) = do {v <- readIORef r; result <- hGetLine h; writeIORef r (v + length result); return result} hCloseC :: HandleC -> IO [Char] hCloseC (h,r) = do {v <- readIORef r; hClose h; return ("Read/Wrote "++ (show v) ++" characters.") } doFileTest f = do { hc <- openFileC f WriteMode; hPutStrC hc "four"; hPutStrC hc "five"; hCloseC hc} -- LI: STickiness of IO here. From mark.pdf cast :: a -> b cast x = unsafePerformIO (do {writeIORef r x; readIORef r} ) where r :: IORef a r = unsafePerformIO (newIORef (error "urk")) -- Logging example from Chapter 14 of RWH newtype Logger a = Logger {execLogger :: (a, Log)} deriving (Show) type Log = [String] runLogger :: Logger a -> (a, Log) runLogger = execLogger record :: String -> Logger () record s = Logger ((), [s]) instance Monad Logger where return i = Logger (i,[]) -- (>>=) :: Logger a -> (a -> Logger b) -> Logger b (>>=) m k = let (i,log1) = runLogger m n = k i (j,log2) = runLogger n in Logger (j, log1 ++ log2) data BTree a = BLeaf a | BNode (BTree a) a (BTree a) deriving (Eq, Show) intTree = BNode (BNode (BLeaf 1) 2 (BLeaf 3)) 4 (BNode (BLeaf 5) 6 (BLeaf 7)) sumTree (BLeaf i) = i sumTree (BNode t1 x t2) = (sumTree t1) + x + (sumTree t2) sumTreeLog :: (Num t) => BTree t -> Logger t sumTreeLog (BLeaf i) = do record (show i) return i sumTreeLog(BNode t1 x t2) = do s1 <- sumTreeLog t2 s2 <- sumTreeLog t1 return (s1 + x + s2) {-- newtype Annotater a = Annotater{execAnnotation :: (a,Int)} deriving (Show) runAnnotator :: Annotator a -> a runAnnotator (Annotator (v,i)) = v runAnnot :: Annotator a -> (a,Int) runAnnot = execAnnotation instance Monad Annotator where return i = Annotator (i,0) -- (>>=) :: Annotator a -> (a -> Annotator b) -> Annotator b m >>= k = let (v1,num1) = runAnnot m n = k v (v2,num2) = runAnnot n in (v2,num2 + 1) sumTreeAnnot :: Tree t -> Annotator t sumTreeAnnot (Leaf i) = return (Leaf (i,0)) sumTreeAnnot (Node t1 x t2) = do a1 <- sumTreeAnnot t1 a2 <- --} guarded :: Bool -> [a] -> [a] guarded True xs = xs guarded False _ = [] multipleTo :: Int -> [(Int,Int)] multipleTo n = do x <- [1..n] y <- [x..n] guarded (x * y == n) $ return (x,y) data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show anLTree = Node (Node (Leaf 'a') (Leaf 'c')) (Node (Leaf 'f') (Leaf 'b')) numberLeaves :: Tree a -> Tree (a,Int) numberLeaves t = let num c (Leaf x) = (Leaf (x,c+1), c+1) num c (Node t1 t2) = let (t1',c1) = num c t1 (t2',c2) = num c1 t2 in (Node t1' t2', c2) (t',c) = num 0 t in t' {-- -- Nl :: Tree a -> Tree(a,Int) nl t = runState label 0 where label (Leaf x) = do n <- modify (1+) return (Leaf (x,n)) label (Node t1 t2) = do t1' <- label t1 t2' <- label t2 return (Node t1' t2') Label (Leaf x) = do n <- modify (1+) return (Leaf (x,n)) label (Node t1 t2) = do t1' <- label t1 t2' <- label t2 return (Node t1' t2') --} tick :: State Int Int tick = do n <- get put (n+1) return n plusOne :: Int -> Int plusOne n = execState tick n {- data MTree a = Nil | Fork a (MTree a) (MTree a) label' = runState relab 0 where relab Nil = return Nil relab (Fork x l r) = do n <- modify (1+) l' <- relab l r' <- relab r return (Fork (n,x) l' r') -} type SimpleState s a = s -> (a,s) -- type IntState a = SimpleState Int aparently type synonyms have to be fully inst. -- Type constructor for Monad is (SimpleState s) returnSt :: a -> (SimpleState s) a returnSt a = \s -> (a,s) bindSt :: ((SimpleState s) a) -> (a -> (SimpleState s) b) -> (SimpleState s) b -- step :: s -> (a,s) -- makeStep :: a -> s -> (b,s) -- result :: s -> (b,s) bindSt step makeStep = \oldState -> let (intermediateResult,intermediateState) = step oldState in (makeStep intermediateResult) intermediateState -- getSt simly returns the current state as its result getSt :: SimpleState s s -- ( s -> (s,s)) getSt s = (s,s) -- putSt takes a state as an argument and installs it putSt :: SimpleState s () -- (s -> ((),s) putSt s = ((),s) newtype StateR s a = StateR { runStateR :: s -> (a,s)} -- runState :: State s a -> s -> (a,s) -- This function simply unwraps a value of type State returnStateR :: a -> StateR s a returnStateR a = StateR $ \s -> (a,s) bindStateR :: StateR s a -> (a -> StateR s b) -> StateR s b bindStateR m k = StateR $ \oldState -> let (a,s') = runStateR m oldState in runStateR (k a) s' getR :: StateR s s getR = StateR (\s -> (s,s)) putR :: s -> StateR s () putR s = StateR $ \s' -> ((),s) instance Monad (StateR s) where return = returnStateR (>>=) = bindStateR -- This type is going to pass around a random number source as its state instance RandomGen Int where next i = (i * 7 + 23, i * 13 - 57) split i = (i - 15, i + 24) genRange i = (-20000, 300000000) type RandomState a = StateR StdGen a getRandomL :: RandomState Int getRandomL = (StateR $ \s->(s,s)) `bindStateR` \gen -> let (val,gen') = random gen in (StateR $ \s' -> ((),gen')) `bindStateR` \_ -> StateR $ \s -> (val,s) {-- bind is going to package up an instance of stateRF when getRandom is invoked, it will pass to stateRF the intial state. stateRF will then "get" this value for "gen" and run the rest of the code in the state available after the get function, which is the same as the intial state. The code then uses random to get a random value and a new seed. We then use bind to change the state being passed to gen', and throw away the result. Finally, return takes the state that resulted from the put and pairs it up with the value val. --} {-- Because the type is monadic, there is something being threaded through. The type of the thing being threaded varies from monad to monad. In the state monad, it is the type of the state. The thing that is being threaded is *implicit*. --} getRandom :: RandomState Int getRandom = getR >>= \gen -> let (val,gen') = random gen in putR gen' >> return val -- The type of this function indicates it is manipulating an implicit integer state getRandom' :: RandomState Int getRandom' = do gen <- getR; let (val,gen') = random gen; putR gen'; return val -- getRandom' just builds up the computation. It doesn't actualy *do* anything -- unti it is run by calling "runStateR" and passing an initial state. exampleGetRandom = (runStateR getRandom') `fmap` getStdGen -- exampleGetRandom1 = runStateR getRandom' 34 --twoBadRandoms :: (RandomGen g) => g -> (Int, Int) twoBadRandoms :: StdGen -> (Int,Int) twoBadRandoms gen = (fst(random gen), fst(random gen)) tbVals = fmap twoBadRandoms getStdGen -- TODO: figure out how to get this to run witout using fmap -- http://haskell.org/ghc/docs/latest/html/libraries/random/System-Random.html -- twoGoodRandoms :: RandomGen g => g -> ((Int,Int), g) twoGoodRandoms :: StdGen -> ((Int,Int),StdGen) twoGoodRandoms gen = let (a,gen') = random gen (b,gen'') = random gen' in ((a,b), gen'') tgVals = fmap twoGoodRandoms getStdGen myLift f m1 m2 = do a <- m1 b <- m2 return (f a b) pair x y = (x,y) getTwoRandoms :: StateR StdGen (Int, Int) getTwoRandoms = myLift pair getRandom getRandom runTwoRandoms :: IO (Int,Int) runTwoRandoms = do oldState <- getStdGen let (result,newState) = runStateR getTwoRandoms oldState setStdGen newState return result exampleRTR :: IO ((Int, Int), StdGen) exampleRTR = runStateR getTwoRandoms `fmap` getStdGen data CountedRandom = CountedRandom { crGen :: StdGen , crCount :: Int } deriving Show type CRState a = StateR CountedRandom a -- Can't show elements of type CRState because they contain functions. getCountedRandom :: CRState Int getCountedRandom = do st <- getR let (val,gen') = random (crGen st) putR CountedRandom {crGen = gen', crCount = crCount st + 1} return val getCount :: CRState Int getCount = crCount `liftM` getR putCount :: Int -> CRState () putCount a = do st <- getR putR st {crCount = a} getMinMaxRandom :: CRState Int getMinMaxRandom = do r1 <- getCountedRandom r2 <- getCountedRandom getCount -- runMinMaxRandom :: IO(Int,Int) runMinMaxRandom = do initState <- getStdGen let r = runStateR getMinMaxRandom (CountedRandom{crGen = initState, crCount = 0}) return r