add examples from lectures

lecture-02/Expr/Expr.hs

+module Expr where
+
+data Expr = Var String
+          | Num Double
+          | Plus Expr Expr
+          | Minus Expr Expr
+          | Times Expr Expr
+          | Div Expr Expr
+          deriving (Eq, Show)
+	  
+evalM :: Monad m=> (String-> m a) -> (a-> a-> m a)-> Expr-> m a
+evalM f p (Var i) = f i
+evalM f p (Plus a b) = do x<- evalM f p a; y <- evalM f p b; p x y

lecture-02/Expr/Expr2.hs

+module Expr2 where
+
+data Expr = Var String
+          | Num Double
+          | Plus Expr Expr
+          | Minus Expr Expr
+          | Times Expr Expr
+          | Div Expr Expr
+	  | Pick Expr Expr
+          deriving (Eq, Show)
+	  

lecture-02/Expr/ListMonad.hs

+module ListMonad where
+
+-- List Monad Instance
+
+import Prelude hiding ((++))
+
+data List a = Nil | a :! (List a)
+            deriving (Read, Show)
+
+(++) :: List a-> List a-> List a
+Nil ++ bs = bs
+(a:! as) ++ bs = a :! (as ++ bs)
+
+instance Functor List where
+  fmap f Nil  = Nil
+  fmap f (a:!as) = f a :! fmap f as
+
+instance Applicative List where
+  pure a = a :! Nil
+  f :! fs <*> a :! as = f a :! (fs <*> as)
+  _ <*> _ = Nil
+
+instance Monad List where
+  a :! as >>= g = g a ++ (as >>= g)
+  Nil >>= g = Nil
+  return a = a :! Nil

lecture-02/Expr/MaybeMonad.hs

+module MaybeMonad where
+
+-- Maybe and Either Monad Instances
+
+import Prelude hiding (Maybe, Just, Nothing, Either, Left, Right)
+
+data Maybe alpha = Just alpha | Nothing
+
+instance Functor Maybe where
+  fmap f (Just a) = Just (f a)
+  fmap f Nothing  = Nothing
+
+instance Applicative Maybe where
+  pure a = Just a
+  Just f <*> Just b = Just (f b)
+  _ <*> _ = Nothing
+
+instance Monad Maybe where
+  Just a >>= g  = g a
+  Nothing >>= g = Nothing
+  return = Just
+
+data Either alpha beta = Left alpha | Right beta
+
+instance Functor (Either alpha) where
+  fmap f (Right b) = Right (f b)
+  fmap f (Left  a) = Left  a
+
+instance Applicative (Either alpha) where
+  pure    = Right 
+  Right f <*> Right b = Right (f b)
+  _ <*> Left b = Left b
+
+instance Monad (Either alpha) where
+  Right b >>= g = g b
+  Left a  >>= _ = Left a
+  return = Right

lecture-02/Expr/ReaderMonad.hs

+module ReaderMonad where
+
+data Reader sigma alpha = R {run :: sigma-> alpha}
+
+instance Functor (Reader sigma) where
+  fmap f (R g) = R (f. g)
+
+instance Applicative (Reader sigma) where
+  pure a = R (const a)
+  R g <*> R f = R $ \s-> g s (f s)
+
+instance Monad (Reader sigma) where
+  return a = R (const a)
+  R f >>= g = R $ \s-> run (g (f s)) s
+
+
+--Elementary operations: reading the state
+get :: (sigma-> alpha)-> Reader sigma alpha
+get f = R $ \s-> f s
+-- equivalent to get = R 
+

lecture-02/Expr/ResMonad.hs

+module ResMonad(
+    Res
+  , run
+  , get
+  , fail
+  , join
+  ) where
+
+import Prelude hiding (fail)
+
+-- The result monad: a combination of reader monad, list monad and maybe monad.
+data Res sigma alpha = Res { run :: sigma-> [Maybe alpha] }
+
+instance Functor (Res sigma) where
+  fmap f (Res g) = Res $ fmap (fmap f). g 
+
+instance Applicative (Res sigma) where
+  pure a = Res (const [Just a])
+  Res f <*> Res a = Res $ \s-> do h<-f s; i<- a s; return $ h <*> i
+
+instance Monad (Res sigma) where
+  return a = Res (const [Just a])
+  Res f >>= g = Res $ \s-> do ma<- f s
+                              case ma of
+			        Just a-> run (g a) s
+			        Nothing-> return Nothing
+
+-- Elementary operations:
+
+get :: (sigma-> alpha)-> Res sigma alpha
+get f = Res $ \s-> [Just $ f s]
+
+fail :: Res sigma alpha
+fail = Res $ const [Nothing]
+
+join :: alpha-> alpha-> Res sigma alpha
+join a b = Res $ \s-> [Just a, Just b]

lecture-02/IMP/Absy.hs

+module Absy where
+
+-- Abstract syntax for a small imperative language
+
+data Cmd = (:=) Var Expr
+         | Block [Cmd]
+         | Print String Expr
+         | Read Var
+         | While BExpr Cmd
+         | If BExpr Cmd Cmd
+         | Break
+         | Throw String
+         | Catch Cmd (String-> Cmd) 
+     
+type Var = String
+
+data Expr = Num Int
+          | Var Var
+          | Plus Expr Expr
+          | Minus Expr Expr
+          | Times Expr Expr
+          | Div Expr Expr
+          | Mod Expr Expr
+
+data BExpr = Eq Expr Expr
+           | Less Expr Expr
+           | Not BExpr
+           | And BExpr BExpr
+           | Or BExpr BExpr
+           | BTrue       

lecture-02/IMP/Examples.hs

+module Examples where
+
+import Absy
+import IMP
+
+-- The factorial
+p1 = Block [ Read "x"
+           , "n" := Num 1
+           , Print "Input: " (Var "x")
+           , While (Less (Num 0) (Var "x")) $ 
+                Block [ "n" := Times (Var "n") (Var "x")
+                      , "x" := Minus (Var "x") (Num 1)
+                      ]
+           , Print "The result is " (Var "n")
+           ]
+
+-- Collatz conjecture 
+p2 = Block [ Read "x"
+           , "c" := Num 0
+           , While BTrue $ 
+               Block [ Print "Tracing: x= " (Var "x")
+                     , If (Eq (Num 0) (Mod (Var "x") (Num 2)))
+                          ("x" := Div (Var "x") (Num 2))
+                          ("x" := Plus (Times (Var "x") (Num 3)) (Num 1))
+                     , If (Eq (Var "x") (Num 1)) Break (Block [])
+                     , "c" := Plus (Var "c") (Num 1)
+                     ] 
+           , Print "Number of steps: " (Var "c")
+           ]

lecture-02/IMP/IMP.hs

+module IMP where
+
+-- A small imperative language
+
+import Text.Read(readMaybe)
+import Data.Maybe(mapMaybe)
+
+import qualified Data.Map as Map
+import Control.Monad.Identity
+import Control.Monad.Except
+import Control.Monad.State.Strict
+import Control.Monad.Writer.Strict
+
+import Absy
+
+data St = St {  mem   :: Map.Map Var Int
+             ,  stdin :: [Int]
+             }
+
+initialState :: [Int]-> St
+initialState i = St Map.empty i
+
+-- Exceptions
+data Exn = BreakExn
+         | User String
+         | Error String
+         deriving Show
+     
+type Imp a = StateT St (WriterT [String] (ExceptT Exn Identity)) a  
+
+readVar :: Var-> Imp Int
+readVar var = do
+  s<- get
+  case Map.lookup var (mem s) of
+    Just i -> return i
+    Nothing -> throwError (Error $ "Invalid variable access "++ var)
+
+writeVar :: Var-> Int-> Imp ()
+writeVar v w = modify $ \s-> s{mem = Map.insert v w (mem s)}
+
+output :: String-> Int-> Imp ()
+output msg i = tell [msg ++ show i]
+
+input :: Imp Int
+input = do
+  s<- get
+  case stdin s of
+    i:is -> do put $ s{stdin = is}
+               return i
+    [] -> throwError (Error $ "Premature EOF")
+
+catch :: Imp ()-> (String-> Imp ())-> Imp ()
+catch i handler =
+  i `catchError` \e-> case e of User str-> handler str; _ -> throwError e
+
+
+-- Evaluate an expression.
+
+liftBinOp :: (Int-> Int-> a)-> Expr-> Expr-> Imp a
+liftBinOp f e1 e2 = do i1<- evalA e1; i2<- evalA e2; return $ f i1 i2
+
+evalA :: Expr-> Imp Int
+evalA (Num i) = return i
+evalA (Var l) = readVar l
+evalA (Plus e1 e2) = liftBinOp (+) e1 e2
+evalA (Minus e1 e2) = liftBinOp (-) e1 e2
+evalA (Times e1 e2) = liftBinOp (*) e1 e2
+evalA (Mod e1 e2) = do v1 <- evalA e1
+                       v2 <- evalA e2
+                       when (v2 == 0) $ throwError (Error $ "Division by zero")
+                       return $ v1 `mod` v2
+evalA (Div e1 e2) = do v1 <- evalA e1
+                       v2 <- evalA e2
+                       when (v2 == 0) $ throwError (Error $ "Division by zero")
+                       return $ v1 `div` v2
+
+evalB :: BExpr -> Imp Bool
+evalB BTrue = return True
+evalB (Eq e1 e2) = liftBinOp (==) e1 e2
+evalB (Less e1 e2) = liftBinOp (<) e1 e2
+evalB (Not b) = do r<- evalB b; return (not r)
+evalB (And b1 b2) = do r1<- evalB b1; r2<- evalB b2; return (r1 && r2)
+evalB (Or b1 b2) = do r1<- evalB b1; r2<- evalB b2; return (r1 || r2)
+
+eval :: Cmd-> Imp ()
+eval (l := e) = do v<- evalA e; writeVar l v
+eval (Block cs) = forM_ cs eval
+eval (Print str e) = do i<- evalA e; output str i
+eval (Read l) = do i<- input; writeVar l i
+eval w@(While c i) =
+  do { b <- evalB c; if b then eval i >> eval w else return () }
+     `catchError` \e-> case e of BreakExn -> return (); _ -> throwError e
+eval (If c p q) = 
+  do b <- evalB c; 
+     if b then eval p else eval q 
+eval Break = throwError BreakExn
+eval (Throw exn) = throwError $ User exn
+eval (Catch i handler) = eval i `catch` \s-> eval $ handler s
+
+readLines :: IO [String]
+readLines = do
+  s <- getLine
+  m <- if (null s) then return [] else readLines
+  return $ s: m
+
+run :: Cmd-> IO ()
+run i = do
+ putStrLn "Please provide input (one number per line, end with empty line):"
+ l <- readLines
+ let ints= mapMaybe readMaybe l
+ let ws = runStateT (eval i) (initialState ints)
+ let out = execWriterT ws
+ case runExcept out of
+   Left ex -> putStrLn $ "*** ERROR: " ++ show ex
+   Right o -> putStr (unlines o)

lecture-02/Scala/State.scala

+case class State[S,A](run: S => (A,S)):
+  def flatMap[B](f: A => State[S,B]): State[S,B] = State { s =>      
+    val (a,s2) = run(s)
+    f(a).run(s2)    
+  }
+  
+  def map[B](f: A => B): State[S,B] = 
+    flatMap(a => State(s => (f(a),s)))
+
+  def eval(s: S): A = run(s)._1
+  def exec(s: S): S = run(s)._2  
+
+object State:
+  def get[S]: State[S,S] = new State(s => (s,s))
+  def put[S](s_ : S): State[S,Unit] = new State(s => ((),s_))
+  def modify[S](f: S => S): State[S,Unit] = get.flatMap(x => put(f(x)))
+
+object Example:
+  def push[A](x: A): State[List[A],Unit] = State.modify(x :: _)
+
+  def pop[A]: State[List[A],A] = for
+    xs <- State.get
+    _ <- State.put(xs.tail)
+  yield xs.head
+  
+  def example: State[List[Int],Int] = for
+    _ <- push(10)
+    _ <- push(20)
+    a <- pop
+    b <- pop
+    _ <- push (a+b)
+    _ <- push(30)
+    a <- pop
+    b <- pop
+    _ <- push (a*b)
+    result <- pop
+  yield result
\ No newline at end of file

lecture-02/Scala/StateT.scala

+import scala.language.higherKinds
+
+trait Monad[M[*]]:
+  def pure[A](a: A): M[A]
+  def bind[A,B](m: M[A], f: A => M[B]): M[B]
+
+object Monad:
+  implicit class MonadOps[M[*], A](m: M[A])(implicit instance: Monad[M]):
+    def flatMap[B](f: A => M[B]): M[B] = instance.bind(m, f)
+    def map[B](f: A => B): M[B] = flatMap(f andThen instance.pure)  
+
+enum Failable[A]:
+  case Success(value: A)
+  case Failure(e: Throwable)
+
+  def success[A](value: A): Failable[A] = Success(value)
+  def fail[A](e: Throwable): Failable[A] = Failure[A](e)
+
+  implicit object MonadInstance extends Monad[Failable]:
+    def pure[A](a: A): Failable[A] = Success(a)
+    def bind[A, B](m: Failable[A], f: A => Failable[B]): Failable[B] =
+      m match
+        case Success(a) => f(a)
+        case Failure(e) => Failure(e)      
+
+  import Monad._
+
+  def example = for
+    a <- success(4)
+    b <- fail[Int](new Exception("whaaat?"))
+    c <- success(7)
+  yield c
+
+case class StateT[M[*],S,A](run: S => M[(A,S)])
+
+object StateT:
+  implicit def monadInstance[M[*],S](implicit m: Monad[M]) =
+    new Monad[({type λ[Y] = StateT[M,S,Y]})#λ]:
+      override def pure[A](a: A): StateT[M, S, A] =
+        StateT(s => m.pure((a,s)))
+
+      override def bind[A, B](f: StateT[M, S, A], g: A => StateT[M, S, B]): StateT[M, S, B] =
+        StateT[M,S,B](s =>
+          m.bind[(A,S),(B,S)](f.run(s), { case (a,s2) => g(a).run(s2) }))    
+
+  def get[M[*],S](implicit m: Monad[M]): StateT[M,S,S] = new StateT(s => m.pure(s,s))
+  def put[M[*],S](s_ : S)(implicit m: Monad[M]): StateT[M,S,Unit] = new StateT(s => m.pure((),s_))
+
+  implicit def lift[M[*],S,A](v: M[A])(implicit m: Monad[M]): StateT[M,S,A] =
+    StateT(s => m.bind(v,(a: A) => m.pure((a,s))))
+
+  import Monad._
+
+  def example = for
+    a <- get[Failable,Int]
+  yield a
\ No newline at end of file

lecture-02/Scala/build.sbt

+name := "02"
+
+version := "0.1"
+
+scalaVersion := "3.1.1"
+
+scalaSource in Compile := baseDirectory.value
+
+unmanagedSources / excludeFilter := "StateT.scala"

lecture-02/Scala/project/build.properties

+sbt.version=1.6.2

lecture-02/StateMonadT.hs

+module StateMonadT where
+
+-- Type representing a state transforming function 
+data StateT m s a = St { runSt :: s-> m (a, s) }
+
+-- Functor instance
+instance Functor m=> Functor (StateT m s) where
+  fmap f st1 = St $ \s-> fmap (\(a1, s1)-> (f a1, s1)) (runSt st1 s)
+
+-- Applicate instance
+instance Monad m=> Applicative (StateT m s) where
+  pure a  = St $ \s-> return (a, s)
+  p <*> q = St $ \s-> do (f, s') <- runSt p s
+                         (a, s'') <- runSt q s'
+                         return (f a, s'')
+
+
+-- Composition: Monad instance
+instance Monad m=> Monad (StateT m s) where
+  f >>= g = St $ \s -> do (a, s') <- runSt f s
+                          runSt (g a) s'
+  return a = St $ \s-> return (a, s)
+
+-- Lifting
+lift :: Monad m=> m a-> StateT m s a
+lift ma = St $ \s-> do a<- ma; return (a, s)
+
+-- Basic operations
+
+-- Reading the state
+get :: Monad m=> (s-> a)-> StateT m s a
+get f = St $ \s-> return (f s, s)
+
+-- Setting the state
+set :: Monad m=> (s-> s)-> StateT m s ()
+set g = St $ \s-> return ((), g s)
+

lecture-02/project/build.properties

+sbt.version=1.6.2

lecture-03/Haskell/ConcExn.hs

+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Exception
+import Control.Concurrent
+
+-- Catch an error call inside an IO action.
+catcherr :: IO ()-> IO ()
+catcherr io = catch io handler where
+  -- Need explicit signature for handler here
+  handler :: ErrorCall -> IO ()
+  handler e = putStrLn "An error call has been caught (and ignored)."
+
+
+ex1 :: IO ()
+ex1 = do
+  m <- newEmptyMVar
+  forkIO (do {s<- takeMVar m; putStrLn s})
+  threadDelay (100000)
+  catcherr $ putMVar m (error "FOO!")
+
+ex2 :: IO ()
+ex2 = do
+  m <- newEmptyMVar
+  forkIO (catcherr (do {s<- takeMVar m; putStrLn s}))
+  threadDelay (100000)
+  putMVar m (error "FOO!")
+
+ex3 :: IO ()
+ex3 = catcherr $ do
+  m <- newEmptyMVar
+  forkIO (do {s<- takeMVar m; putStrLn s})
+  threadDelay (100000)
+  putMVar m (error "FOO!")
+

lecture-03/Haskell/Robots3.hs

+module Robots3 where
+
+import Control.Concurrent
+import System.Random
+
+data Robot = Robot {id :: Int, pos :: Int, battery :: Int}
+
+instance Show Robot where
+  show (Robot i p b) = "Robot #"++ show i++ " at "++ show p++ " [battery: "++ show b++ "]"
+
+-- Move given robot by n units in separate thread, 
+-- return a future which gets filled once movement is complete
+move :: Robot-> Int-> IO (MVar Robot)
+move r n = do
+  f <- newEmptyMVar; forkIO (mv f r n); return f where
+  mv f r n
+   | n <= 0 || battery r <= 0 = putMVar f r
+   | otherwise =  do
+      m<- randomRIO(0,10); threadDelay(m*100000)
+      putStrLn $ "Bleep, bleep: "++ show r
+      mv f r{pos= pos r+ 1, battery= battery r- 1} (n-1)
+

lecture-03/Haskell/RobotsEx1.hs

+module RobotsEx1 where
+
+import Control.Concurrent
+import System.Random
+import Robots3
+
+ex :: IO ()
+ex = do
+  let swarm = [Robot i 0 5 | i<- [1..6]]
+  fs <- mapM (\r-> do { n <- randomRIO (0, 10); move r n }) swarm
+  putStrLn "Started moving robots..."

lecture-03/Haskell/RobotsEx2.hs

+module RobotsEx2 where
+
+import Control.Concurrent
+import System.Random
+import Robots3
+
+ex :: IO ()
+ex = do
+  let swarm = [Robot i 0 5 | i<- [1..6]]
+  fs <- mapM (\r-> do { n <- randomRIO (0, 10); move r n }) swarm
+  putStrLn "Started moving robots..."
+  mapM_ (\f-> takeMVar f >>= putStrLn. show) fs
+  putStrLn "Finished moving robots"

lecture-03/Haskell/RobotsEx3.hs

+module RobotsEx3 where
+
+import Control.Concurrent
+import Control.Monad(when)
+import System.Random
+import Robots3
+
+ex :: IO ()
+ex = do
+  let swarm = [Robot i 0 10 | i<- [1 .. numRobots]]
+  fs <- mapM (\r-> do { n <- randomRIO (0, 10); move r n }) swarm
+  putStrLn "Started moving robots..."
+  cnt <- newMVar numRobots
+  finished <- newEmptyMVar
+  mapM_ (\v-> forkIO (watchRobot v cnt finished)) fs
+  takeMVar finished
+  putStrLn "Finished moving robots..."
+  where
+    numRobots = 6
+    watchRobot v cnt f = do
+      r<- takeMVar v
+      c<- modifyMVar cnt $ \c-> return (c-1, c-1)
+      putStrLn $ "Finished: "++ show r++ "(" ++ show c ++ " robots left.)"
+      when (c == 0) $ putMVar f ()
+