Skip to content
Snippets Groups Projects
Commit f35e3703 authored by Martin Ring's avatar Martin Ring
Browse files

add examples from lectures

parent 070d5982
No related branches found
No related tags found
No related merge requests found
Showing
with 565 additions and 0 deletions
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
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)
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
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
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
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]
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
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")
]
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)
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
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
name := "02"
version := "0.1"
scalaVersion := "3.1.1"
scalaSource in Compile := baseDirectory.value
unmanagedSources / excludeFilter := "StateT.scala"
sbt.version=1.6.2
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)
sbt.version=1.6.2
{-# 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!")
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)
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..."
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"
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 ()
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment