add examples from lectures

lecture-01/Haskell/Examples.hs

+module Examples where
+
+import Data.Char (isUpper, toLower)
+import StateMonad
+
+import qualified SimpleRefs as SR
+import Refs
+import WriterMonad
+
+
+
+-- examples for writer monad
+
+ex1 :: Writer String Int
+ex1 = do let a= 3+4
+         tell $ "Calculated a " ++ show a ++ "\n"
+	 let b= 8* 3
+	 tell $ "Calculated b " ++ show b ++ "\n"
+	 return $ a+ b
+
+ex1a :: Logger Int
+ex1a = do let a= 3+4
+          logger $ "Calculated a: " ++ show a
+	  let b= 8* 3
+	  logger $ "Calculated b: " ++ show b
+	  return $ a+ b
+
+
+-- examples for state Monad
+-- Example using a very simple state
+type WithCounter alpha = State Int alpha
+
+-- This function is like toLower, but also counts the number of upper-case
+-- characters converted to lower.
+cntToLower :: String-> (String, Int)
+cntToLower s = run (cntToL s) 0
+
+-- Main function : we can now use monad syntax!
+cntToL :: String-> WithCounter String
+cntToL [] = return ""
+cntToL (x:xs)
+  | isUpper x =  do ys<- cntToL xs 
+                    set (+1)
+                    return (toLower x: ys)
+  | otherwise =  do { ys<- cntToL xs; return (x: ys) }
+
+
+-- Examples for references
+
+ex2 :: SR.Stateful Int String
+ex2 = do r<- SR.newRef 43 
+         s<- SR.newRef 17
+	 SR.writeRef r 99
+	 SR.writeRef s 17
+	 v<- SR.readRef r
+	 w<- SR.readRef s
+	 return $ "r= "++ show v++ ", s= "++ show w
+
+ex3 :: Stateful String
+ex3 = do r<- newRef ""
+         s<- newRef (0 :: Int)
+	 writeRef r "Foo"
+	 writeRef s 43
+	 vr <- readRef r
+         vs <- readRef s
+	 return $ vr ++ show vs

lecture-01/Haskell/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-01/Haskell/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-01/Haskell/Perms.hs

+module Perms where
+
+-- Ohne Monaden-Notation
+ins' :: alpha-> [alpha]-> [[alpha]]
+ins' x [] = [[x]]
+ins' x (y:ys) = [x:y:ys] ++ map (y :) (ins' x ys)
+
+perms' :: [alpha]-> [[alpha]]
+perms' [] = [[]]
+perms' (x:xs) = [is | ps <- perms' xs, is <- ins' x ps ]
+
+-- In Monaden-Notation:
+ins :: alpha-> [alpha]-> [[alpha]]
+ins x [] = return [x]
+ins x (y:ys) = [x:y:ys] ++ do
+  is <- ins x ys
+  return $ y:is
+
+perms :: [alpha]-> [[alpha]]
+perms [] = return []
+perms (x:xs) = do
+  ps <- perms xs
+  is <- ins x ps
+  return is

lecture-01/Haskell/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-01/Haskell/Refs.hs

+module Refs(
+    Ref
+  , Stateful
+  , readRef
+  , writeRef
+  , newRef
+  , runSt
+  ) where
+
+-- Typed references
+
+import qualified Data.Map as Map
+import Data.Map(Map)
+import Text.Printf
+import Data.Dynamic
+
+import StateMonad
+
+newtype Ref alpha  = Ref Int
+
+-- The memory maps references to alpha  values, and keeps track of the next
+--  fresh reference.
+data Mem = Mem { fresh :: Int, mem   :: Map Int Dynamic }
+
+-- A stateful computation is a state monad with a memory as a state
+type Stateful beta = State Mem beta
+   -- This is slightly unsafe because the type synonym is not opaque
+
+-- Elementary operations
+
+readRef :: Typeable alpha=> Ref alpha-> Stateful alpha
+readRef (Ref i) = get $ \m->
+  case Map.lookup i (mem m) of
+    Just a -> case fromDynamic a of
+                Just v -> v
+                Nothing -> error $ printf "readRef: Refence %06x ill-typed" i
+    Nothing -> error $ printf "readRef: Reference %06x not defined" i
+writeRef :: Typeable alpha=> Ref alpha-> alpha-> Stateful ()
+writeRef (Ref i) a  = set $ \m-> m{mem = Map.insert i (toDyn a) (mem m)}
+
+newRef :: Typeable alpha=> alpha-> Stateful (Ref alpha)
+newRef a  = do i <- get fresh
+               set $ \m-> m {mem= Map.insert i (toDyn a) (mem m), fresh= i+1}
+               return $ Ref i
+
+-- Run alpha  stateful computation with an empty state
+runSt :: Stateful beta -> beta
+runSt s = fst $ StateMonad.run s $ Mem { fresh= 0, mem= Map.empty } 
+

lecture-01/Haskell/SimpleRefs.hs

+module SimpleRefs(
+    Ref
+  , Stateful
+  , readRef
+  , writeRef
+  , newRef
+  , runSt
+  ) where
+
+import qualified Data.Map as Map
+import Data.Map(Map)
+import Text.Printf
+
+import StateMonad
+
+newtype Ref = Ref Int
+
+-- The memory maps references to a values, and keeps track of the next
+--  fresh reference.
+data Mem alpha = Mem { fresh :: Int, mem   :: Map Int alpha }
+
+-- A stateful computation is a state monad with a memory as a state
+type Stateful alpha beta = State (Mem alpha) beta
+
+-- Elementary operations
+
+readRef :: Ref-> Stateful alpha alpha
+readRef (Ref i) = get $ \m->
+  case Map.lookup i (mem m) of
+    Just a -> a
+    Nothing -> error $ printf "readRef: Reference %08x not defined." i
+
+writeRef :: Ref-> alpha-> Stateful alpha ()
+writeRef (Ref i) a = set $ \m-> m{mem = Map.insert i a (mem m)}
+
+newRef :: alpha-> Stateful alpha Ref
+newRef a = do i <- get fresh
+              set $ \m-> m { mem= Map.insert i a (mem m), fresh= i+1 }
+	      return $ Ref i
+
+-- Run a stateful computation with a new state
+
+runSt :: Stateful alpha beta -> beta
+runSt s = fst $ StateMonad.run s $ Mem { fresh= 0, mem= Map.empty } 
+

lecture-01/Haskell/SimpleState.hs

+module SimpleState where
+
+import Prelude hiding (curry, uncurry, map)
+import Data.Char (isUpper, toLower)
+
+curry   :: ((alpha, beta) -> gamma)-> alpha-> beta-> gamma
+uncurry :: (alpha-> beta-> gamma)-> (alpha, beta) -> gamma
+
+curry f a b     = f (a, b)
+uncurry f (a, b)= f a b    
+
+-- A very simple ``state transformer''
+
+-- Type representing a state transforming function
+type State sigma alpha = sigma-> (alpha, sigma)
+
+-- Composition of two state transformers
+comp :: State sigma alpha-> (alpha-> State sigma beta)-> State sigma beta
+comp f g = uncurry g . f
+
+-- Lifting: the trivial state transformer
+lift :: alpha-> State sigma alpha
+lift = curry id
+
+-- Transforming functions
+map :: (alpha-> beta)-> State sigma alpha-> State sigma beta
+map f g = (\(a, s)-> (f a, s)) . g
+
+-- Basic operations
+
+-- Reading the state
+get :: (sigma-> alpha)-> State sigma alpha
+get f s = (f s, s)
+
+-- Setting the state
+set :: (sigma-> sigma)-> State sigma ()
+set g s = ((), g s)
+
+-- Example using a very simple state
+type WithCounter alpha = State Int alpha
+
+
+-- This function is like toLower, but also counts the number of upper-case
+-- characters converted to lower.
+cntToLower :: String-> (String, Int)
+cntToLower s = cntToL s 0
+
+-- Main function 
+cntToL :: String-> WithCounter String
+cntToL [] = lift ""
+cntToL (x:xs)
+  | isUpper x =  cntToL xs `comp`
+                 \ys-> set (+1) `comp`
+                 \()-> lift (toLower x: ys)
+  | otherwise = cntToL xs `comp` \ys-> lift (x: ys)

lecture-01/Haskell/StateMonad.hs

+module StateMonad(
+    State
+  , get
+  , set
+  , run
+  ) where
+
+-- The simple state transformer as a monad
+
+-- Type representing a state transforming function
+-- We need to wrap this in a datatype to be able to make it into an instance
+data State sigma alpha = St { run :: sigma-> (alpha, sigma) }
+
+-- Transforming functions: Functor instance
+instance Functor (State sigma) where
+  fmap f g = St $ \s-> (\(a, s1)-> (f a, s1)) (run g s)
+
+-- Applicate instance
+instance Applicative (State sigma) where
+  pure a  = St $ \s-> (a, s)
+  p <*> q = St $ \s-> let (f, s') = run p s
+                          (a, s'') = run q s'
+                      in  (f a, s'')
+
+-- Composition and lifting: Monad instance
+instance Monad (State sigma) where
+  f >>= g = St $ \s -> let (a, s')= run f s
+                       in  run (g a) s'
+  return a = St $ \s-> (a, s)
+
+
+-- Basic operations
+
+-- Reading the state
+get :: (sigma-> alpha)-> State sigma alpha
+get f = St $ \s-> (f s, s)
+
+-- Setting the state
+set :: (sigma-> sigma)-> State sigma ()
+set g = St $ \s-> ((), g s)

lecture-01/Haskell/WriterMonad.hs

+module WriterMonad where
+
+import Data.Monoid
+
+data Writer sigma alpha = W sigma alpha
+
+instance Functor (Writer sigma) where
+  fmap f (W s a) = W s $ f a
+
+instance Monoid sigma=> Applicative (Writer sigma) where
+  pure a = W mempty a
+  W s1 f <*> W s2 a = W (s1 `mappend` s2) $ f a 
+
+instance Monoid sigma=> Monad (Writer sigma) where
+  return a = W mempty a
+  (W s1 a) >>= g = let W s2 b = g a
+                   in  W (s1 `mappend` s2) b
+
+tell :: sigma-> Writer sigma ()
+tell s = W s ()
+
+runW :: Writer sigma a-> (sigma, a)
+runW (W s a) = (s, a)
+
+-- A logging monad
+
+type Logger = Writer [String]
+
+logger :: String-> Logger ()
+logger s = tell [s] 
+
+runLog :: Logger a-> IO a
+runLog c = let (l, a) = runW c
+           in  do putStrLn $ unlines l; return a

lecture-01/Scala/Expr.scala

+import scala.util.Try
+
+enum Operator:
+  case Plus
+  case Times
+  case Minus
+  case DivideBy
+
+  override def toString: String = this match
+    case Plus => "+"
+    case Times => "*"
+    case Minus => "-"
+    case DivideBy => "/"
+
+enum Expr:
+  case Binary(operator: Operator, left: Expr, right: Expr)
+  case Const(value: Int)
+  case Variable(identifier: String)
+
+  override def toString: String = this match
+    case Binary(op,l,r) => s"$l $op $r"
+    case Const(v) => v.toString
+    case Variable(i) => i
+
+object Expr:
+  def eval(expr: Expr, env: Map[String,Int]): Option[Int] = 
+    expr match 
+      case Const(v) => Some(v)
+      case Binary(op,l,r) => 
+        val f: (Int,Int) => Int = op match 
+          case Operator.Plus => _ + _
+          case Operator.Minus => _ - _
+          case Operator.Times => _ * _
+          case Operator.DivideBy => _ / _
+        for
+          l <- eval(l,env)
+          r <- eval(r,env)
+          res <- Try(f(l,r)).recover{ case e if !e.isInstanceOf[ArithmeticException] => throw e }.toOption
+        yield res
+      case Variable(i) =>
+        env.get(i)

lecture-01/Scala/Ordered.scala

+enum Order:
+  case LessThan
+  case Equal
+  case GreaterThan
+
+trait Ordered[T]:
+  def compare(a: T, b: T): Order
+
+def compare[T](a: T, b: T)(implicit order: Ordered[T]): Order =
+  order.compare(a,b)
+
+implicit class OrderOperators[T](a: T)(implicit order: Ordered[T]):
+  def >(b: T): Boolean = compare(a,b) == Order.GreaterThan
+  def <(b: T): Boolean = compare(a,b) == Order.LessThan
\ No newline at end of file

lecture-01/Scala/Rational.scala

+case class Rational(num: Int, denom: Int)
+
+object Rational:
+  implicit object OrderedRational extends Ordered[Rational]:
+    def compare(a: Rational, b: Rational): Order = 
+      a.num * b.denom - b.num * a.denom match
+        case x if x > 0 => Order.GreaterThan
+        case x if x < 0 => Order.LessThan
+        case _ => Order.Equal
\ No newline at end of file

lecture-02/Example.hs

+module Example where
+
+import Control.Monad.Identity
+import StateMonadT
+import ExnMonadT
+
+type State = Int
+type Error = String
+
+type ResMonad a = StateT (ExnT Identity Error) State a 
+
+exm1 :: ResMonad Int
+exm1 = do a<- get id
+          if (a == 0) then lift $ err "NULL!"
+	              else set  $ \_ -> a+1
+          return a
+
+

lecture-02/ExnMonadT.hs

+module ExnMonadT where
+
+-- Maybe and Either Monad Instances
+
+{- This is predefined:
+data Either alpha beta = Left alpha | Right beta
+-}
+
+data ExnT m e a = ExnT { runEx :: m (Either e a) }
+
+instance Functor m=> Functor (ExnT m e) where
+  fmap f (ExnT a) = ExnT (fmap (fmap f) a)
+
+instance Monad m=> Applicative (ExnT m e) where
+  pure   = ExnT . pure . Right
+  ExnT fm <*> ExnT ma = ExnT $ do ef<- fm; ea<- ma; return $ ef <*> ea
+
+instance Monad m=> Monad (ExnT m e) where
+  return = ExnT . return . Right
+  ExnT ma >>= g = ExnT $ do e <- ma
+                            case e of Right a -> runEx (g a)
+                                      Left err -> return (Left err)
+
+
+-- Operations:
+
+err :: Monad m=> e-> ExnT m e a
+err = ExnT. return. Left

lecture-02/Expr/EvalFull.hs

+module EvalFull where
+
+import Prelude hiding (fail)
+
+import Expr2
+import ResMonad
+import qualified Data.Map as M
+
+type State = M.Map String Double
+
+eval :: Expr -> Res State Double
+eval (Var i)  = get (M.! i)
+eval (Num n)  = return n
+eval (Plus a b)  = do x<- eval a; y<- eval b; return $ x+ y
+eval (Minus a b) = do x<- eval a; y<- eval b; return $ x- y
+eval (Times a b) = do x<- eval a; y<- eval b; return $ x* y
+eval (Div a b)   = do x<- eval a; y<- eval b
+                      if y == 0 then fail else return $ x / y
+eval (Pick a b)  = do x<- eval a; y<- eval b; join x y
+
+{-
+-- Examples:
+s = M.fromList[("a", 3), ("b", 7)]
+run (eval (Plus (Var "a") (Var "b"))) s
+
+run (eval (Plus (Num 3) (Div (Var "b") (Minus (Num 3) (Var "a"))))) s
+
+run (eval (Plus (Num 3) (Div (Var "a") (Var "b")))) s
+
+run (eval (Div (Pick (Var "a") (Num 5)) (Pick (Var "b") (Num 0)))) s
+
+-}

lecture-02/Expr/EvalND.hs

+module EvalND where
+
+import Expr2
+
+eval :: Expr -> [Double]
+eval (Var i)  = return 0
+eval (Num n)  = return n
+eval (Plus a b)  = do x<- eval a; y<- eval b; return $ x+ y
+eval (Minus a b) = do x<- eval a; y<- eval b; return $ x- y
+eval (Times a b) = do x<- eval a; y<- eval b; return $ x* y
+eval (Div a b)   = do x<- eval a; y<- eval b; return $ x/ y
+eval (Pick a b)  = do x<- eval a; y<- eval b; [x, y]
+
+{-
+-- Examples:
+
+eval (Plus (Num 3) (Pick (Num 4) (Num 5)))
+eval (Times (Pick (Num 4) (Num 5)) (Pick (Num 1) (Num 0)))
+
+-}

lecture-02/Expr/EvalPartial.hs

+module EvalPartial where
+
+import Expr
+
+eval :: Expr -> Maybe Double
+eval (Var _)  = return 0
+eval (Num n)  = return n
+eval (Plus a b)  = do x<- eval a; y<- eval b; return $ x+ y
+eval (Minus a b) = do x<- eval a; y<- eval b; return $ x- y
+eval (Times a b) = do x<- eval a; y<- eval b; return $ x* y
+eval (Div a b)   = do
+  x<- eval a; y<- eval b; if y == 0 then Nothing else Just $ x/ y
+
+{-
+-- Examples:
+eval (Plus (Num 3) (Div (Times (Num 4) (Num 5)) (Minus (Num 3) (Num 3))))
+eval (Plus (Num 3) (Div (Times (Num 4) (Num 5)) (Minus (Num 4) (Num 3))))
+
+-}

lecture-02/Expr/EvalPlain.hs

+module EvalPlain where
+
+import Expr
+
+eval :: Expr -> Double
+eval (Var _)  = 0
+eval (Num n)  = n
+eval (Plus a b)  = eval a+ eval b
+eval (Minus a b) = eval a- eval b
+eval (Times a b) = eval a* eval b
+eval (Div a b)   = eval a/ eval b
+

lecture-02/Expr/EvalStateful.hs

+module EvalStateful where
+
+import Expr
+import ReaderMonad
+import qualified Data.Map as M
+
+type State = M.Map String Double
+
+eval :: Expr -> Reader State Double
+eval (Var i)  = get (M.! i)
+eval (Num n)  = return n
+eval (Plus a b)  = do x<- eval a; y<- eval b; return $ x+ y
+eval (Minus a b) = do x<- eval a; y<- eval b; return $ x- y
+eval (Times a b) = do x<- eval a; y<- eval b; return $ x* y
+eval (Div a b)   = do x<- eval a; y<- eval b; return $ x/ y
+
+{-
+-- Example:
+
+s = M.fromList[("a", 3), ("b", 7)]
+run (eval (Plus (Var "a") (Var "b"))) s
+
+-}