Commit 85c89567 authored by Job Cuppen's avatar Job Cuppen
Browse files

week10 wip

parent 554f532f
module skeleton10
/*
Advanved Progrmming 2019, Assignment 10
Pieter Koopman, pieter@cs.ru.nl
*/
import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
/*
qualified import of the named objects to avoid name conflicts.
Use this as 'iTasks'.return. All other parts of iTasks are available.
*/
import Data.Functor, Control.Applicative, Control.Monad
import Data.Tuple
import qualified Text as Text
from Data.Set import instance == (Set a), instance < (Set a), instance Foldable Set
//from Data.Set import fromList
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
//import qualified Data.Foldable as Fold
// use this as: 'List'.union
// ================ the DSL ===============
:: Expression
= New [Int]
| Elem Int
| Variable Ident
| Size Set
| (+.) infixl 6 Expression Expression
| (-.) infixl 6 Expression Expression
| (*.) infixl 7 Expression Expression
| (=.) infixl 2 Ident Expression
:: Logical
= TRUE
| FALSE
| (In) infix 4 Elem Set
| (==.) infix 4 Expression Expression
| (<=.) infix 4 Expression Expression
| Not Logical
| (||.) infixr 2 Logical Logical
| (&&.) infixr 3 Logical Logical
:: Stmt
= Expression Expression
| Logical Logical
| For Ident Set Stmt
| If Logical Stmt Stmt
:: Set :== Expression
:: Elem :== Expression
:: Ident :== String
// === State
:: Val
= BOOL Bool
| NUMBER Int
| SET ('iTasks'.Set Int)
:: State :== Map Ident Val
// === semantics
:: Result a = Res a | Fail String
:: Sem a = Sem (State -> (Result a, State))
fail :: String -> Sem a
fail str = Sem \s.(Fail str, s)
instance Functor Result where
fmap f (Res a) = (Res (f a))
instance pure Result where
pure a = (Res a)
instance Functor Sem where
fmap f (Sem a) = Sem \s.
let (b, s1) = a s
in (fmap f b, s1)
instance pure Sem where
pure a = Sem \s->(pure a, s)
instance <*> Result where
(<*>) (Fail str) _ = (Fail str)
(<*>) (Res f) ra = fmap f ra
instance <*> Sem where
(<*>) (Sem ab) (Sem a) = Sem \s1 ->
let (rab, s2) = ab s1
(ra, s3) = a s2
in (rab <*> ra, s3)
fromMaybe :: (Maybe a) -> (Result a)
fromMaybe (Just a) = Res a
fromMaybe (Nothing) = Fail "ERROR while getting from state"
instance Monad Result where
bind (Res a) f = f a
bind (Fail str) _ = (Fail str)
instance Monad Sem where
bind (Sem f) g = Sem \s1 -> case f s1 of
(Res a, s2) -> unSem (g a) s2
(Fail s, s2) -> (Fail s, s2)
unSem :: (Sem a) -> (State -> (Result a, State))
unSem (Sem f) = f
store :: Ident Val -> Sem Val
store i v = Sem \s->(pure v, ('Map'.put i v s))
read :: Ident -> Sem Val
read i = Sem \s->(fromMaybe ('Map'.get i s), s)
ourMap :: Int ('iTasks'.Set Int) -> ('iTasks'.Set Int)
ourMap i s = 'Set'.fromList (map (\x->(x*i)) ('Set'.toList s))
eval :: Expression -> Sem Val
eval (New list) = pure (SET ('Set'.fromList list))
eval (Elem i) = pure (NUMBER i)
eval (Variable id) = read id
eval (Size e) = eval e >>= \a.case a of
NUMBER i -> fail "Can't have size of number"
SET s -> pure (NUMBER (length ('Set'.toList s)))
eval (+. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 + a2))
SET s1 -> pure (SET ('Set'.union ('Set'.singleton a1) s1))
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.union s1 s2))
NUMBER a2 -> pure (SET ('Set'.union ('Set'.singleton a2) s1))
eval (-. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 - a2))
SET s1 -> fail "Int -. Set is impossible"
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.difference s1 s2))
NUMBER a2 -> pure (SET ('Set'.difference s1 ('Set'.singleton a2)))
eval (*. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 * a2))
SET s1 -> pure (SET (ourMap a1 s1))
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.intersection s1 s2))
NUMBER a2 -> fail "Set *. Int is impossible"
eval (=. i e) = eval e >>= \a.store i a
logicEval :: Logical -> Sem Bool
logicEval TRUE = pure (True)
logicEval FALSE = pure (False)
logicEval (In e s1) =
eval e >>= \ee.
case ee of
NUMBER n -> eval s1 >>= \es.
case es of
SET s2 -> pure ('Set'.member n s2)
_ -> fail "Numbers can not contain numbers"
_ -> fail "Sets are not elements"
logicEval (==. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (a1 == a2)
_ -> fail "Different Type"
SET s1 -> case a2 of
SET s2 -> pure (s1 == s2)
_ -> fail "Different Type"
logicEval (<=. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (a1 <= a2)
_ -> fail "Different Type"
SET s1 -> case a2 of
SET s2 -> pure (s1 <= s2)
_ -> fail "Different Type"
logicEval (Not l1) = logicEval l1 >>= \b. pure (not b)
logicEval (&&. l1 l2) =
logicEval l1 >>= \b1.
logicEval l2 >>= \b2. pure (b1 && b2)
logicEval (||. l1 l2) =
logicEval l1 >>= \b1.
logicEval l2 >>= \b2. pure (b1 || b2)
stmtEval (For i st stmt) = forEval i ('Set'.toList st) stmt
forEval :: Ident [Int] Stmt -> Sem ()
forEval i [elem:elems] stmt = (store id (NUMBER elem)) >>| (stmtEval stmt) >>| (forEval i elems stmt)
// === Printing
class printable a where
print :: a -> String
instance printable Expression where
print (New ls) = "[" +++ (foldr (\x y.x+++","+++y) "" (map toString ls)) +++ "]"
print (Elem i) = toString i
print (Variable id) = id
print (Size expr) = "size(" +++ print expr +++ ")"
print (+. e1 e2) = print e1+++ " + "+++ print e2
print (-. e1 e2) = print e1+++ " - "+++ print e2
print (*. e1 e2) = print e1+++ " * "+++ print e2
print (=. id expr) = id+++ " = "+++ print expr
instance printable Logical where
print TRUE = toString True
print FALSE = toString False
print (In e s) = print s +++ ".contains(" +++ print e +++ ")"
print (==. e s) = print e +++ "==" +++ print e
print (<=. e s) = print e +++ "<=" +++ print e
print (Not l) = "!" +++ print l
print (&&. l1 l2) = print l1 +++ "&&" +++ print l2
print (||. l1 l2) = print l1 +++ "||" +++ print l2
instance printable Stmt where
print (If l stmt1 stmt2) = "if " +++ print l +++ " do " +++ print stmt1 +++ " else " +++ print stmt2
print (For i st stmt) = "for " +++ i +++ " in " +++ print st +++ " do " +++ print stmt
print (Expression e) = print e
print (Logical l) = print l
// === simulation
(>>>=) :== tbind
(>>>|) a b :== tbind a (\_ -> b)
myExp = (Size (New [1,2,3] +. Elem 2))
Start = let (Sem f) = (eval myExp) in f ('Map'.newMap)
module skeleton10
/*
Advanved Progrmming 2019, Assignment 10
Pieter Koopman, pieter@cs.ru.nl
*/
import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
/*
qualified import of the named objects to avoid name conflicts.
Use this as 'iTasks'.return. All other parts of iTasks are available.
*/
import Data.Functor, Control.Applicative, Control.Monad
import Data.Tuple
import qualified Text as Text
from Data.Set import instance == (Set a), instance < (Set a), instance Foldable Set
//from Data.Set import fromList
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
//import qualified Data.Foldable as Fold
// use this as: 'List'.union
// ================ the DSL ===============
:: Expression
= New [Int]
| Elem Int
| Variable Ident
| Size Set
| (+.) infixl 6 Expression Expression
| (-.) infixl 6 Expression Expression
| (*.) infixl 7 Expression Expression
| (=.) infixl 2 Ident Expression
:: Logical
= TRUE
| FALSE
| (In) infix 4 Elem Set
| (==.) infix 4 Expression Expression
| (<=.) infix 4 Expression Expression
| Not Logical
| (||.) infixr 2 Logical Logical
| (&&.) infixr 3 Logical Logical
:: Stmt
= Expression Expression
| Logical Logical
| For Ident Set Stmt
| If Logical Stmt Stmt
:: Set :== Expression
:: Elem :== Expression
:: Ident :== String
// === State
:: Val
= BOOL Bool
| NUMBER Int
| SET ('iTasks'.Set Int)
:: State :== Map Ident Val
// === semantics
:: Result a = Res a | Fail String
:: Sem a = Sem (State -> (Result a, State))
fail :: String -> Sem a
fail str = Sem \s.(Fail str, s)
instance Functor Result where
fmap f (Res a) = (Res (f a))
instance pure Result where
pure a = (Res a)
instance Functor Sem where
fmap f (Sem a) = Sem \s.
let (b, s1) = a s
in (fmap f b, s1)
instance pure Sem where
pure a = Sem \s->(pure a, s)
instance <*> Result where
(<*>) (Fail str) _ = (Fail str)
(<*>) (Res f) ra = fmap f ra
instance <*> Sem where
(<*>) (Sem ab) (Sem a) = Sem \s1 ->
let (rab, s2) = ab s1
(ra, s3) = a s2
in (rab <*> ra, s3)
fromMaybe :: (Maybe a) -> (Result a)
fromMaybe (Just a) = Res a
fromMaybe (Nothing) = Fail "ERROR while getting from state"
instance Monad Result where
bind (Res a) f = f a
bind (Fail str) _ = (Fail str)
instance Monad Sem where
bind (Sem f) g = Sem \s1 -> case f s1 of
(Res a, s2) -> unSem (g a) s2
(Fail s, s2) -> (Fail s, s2)
unSem :: (Sem a) -> (State -> (Result a, State))
unSem (Sem f) = f
store :: Ident Val -> Sem Val
store i v = Sem \s->(pure v, ('Map'.put i v s))
read :: Ident -> Sem Val
read i = Sem \s->(fromMaybe ('Map'.get i s), s)
ourMap :: Int ('iTasks'.Set Int) -> ('iTasks'.Set Int)
ourMap i s = 'Set'.fromList (map (\x->(x*i)) ('Set'.toList s))
eval :: Expression -> Sem Val
eval (New list) = pure (SET ('Set'.fromList list))
eval (Elem i) = pure (NUMBER i)
eval (Variable id) = read id
eval (Size e) = eval e >>= \a.case a of
NUMBER i -> fail "Can't have size of number"
SET s -> pure (NUMBER (length ('Set'.toList s)))
eval (+. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 + a2))
SET s1 -> pure (SET ('Set'.union ('Set'.singleton a1) s1))
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.union s1 s2))
NUMBER a2 -> pure (SET ('Set'.union ('Set'.singleton a2) s1))
eval (-. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 - a2))
SET s1 -> fail "Int -. Set is impossible"
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.difference s1 s2))
NUMBER a2 -> pure (SET ('Set'.difference s1 ('Set'.singleton a2)))
eval (*. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (NUMBER (a1 * a2))
SET s1 -> pure (SET (ourMap a1 s1))
SET s1 -> case a2 of
SET s2 -> pure (SET ('Set'.intersection s1 s2))
NUMBER a2 -> fail "Set *. Int is impossible"
eval (=. i e) = eval e >>= \a.store i a
logicEval :: Logical -> Sem Bool
logicEval TRUE = pure (True)
logicEval FALSE = pure (False)
logicEval (In e s1) =
eval e >>= \ee.
case ee of
NUMBER n -> eval s1 >>= \es.
case es of
SET s2 -> pure ('Set'.member n s2)
_ -> fail "Numbers can not contain numbers"
_ -> fail "Sets are not elements"
logicEval (==. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (a1 == a2)
_ -> fail "Different Type"
SET s1 -> case a2 of
SET s2 -> pure (s1 == s2)
_ -> fail "Different Type"
logicEval (<=. e1 e2) =
eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
NUMBER a1 -> case a2 of
NUMBER a2 -> pure (a1 <= a2)
_ -> fail "Different Type"
SET s1 -> case a2 of
SET s2 -> pure (s1 <= s2)
_ -> fail "Different Type"
logicEval (Not l1) = logicEval l1 >>= \b. pure (not b)
logicEval (&&. l1 l2) =
logicEval l1 >>= \b1.
logicEval l2 >>= \b2. pure (b1 && b2)
logicEval (||. l1 l2) =
logicEval l1 >>= \b1.
logicEval l2 >>= \b2. pure (b1 || b2)
// === Printing
class printable a where
print :: a -> String
instance printable Expression where
print (New ls) = "[" +++ (foldr (\x y.x+++","+++y) "" (map toString ls)) +++ "]"
print (Elem i) = toString i
print (Variable id) = id
print (Size expr) = "size(" +++ print expr +++ ")"
print (+. e1 e2) = print e1+++ " + "+++ print e2
print (-. e1 e2) = print e1+++ " - "+++ print e2
print (*. e1 e2) = print e1+++ " * "+++ print e2
print (=. id expr) = id+++ " = "+++ print expr
instance printable Logical where
print TRUE = toString True
print FALSE = toString False
print (In e s) = print s +++ ".contains(" +++ print e +++ ")"
print (==. e s) = print e +++ "==" +++ print e
print (<=. e s) = print e +++ "<=" +++ print e
print (Not l) = "!" +++ print l
print (&&. l1 l2) = print l1 +++ "&&" +++ print l2
print (||. l1 l2) = print l1 +++ "||" +++ print l2
// === simulation
(>>>=) :== tbind
(>>>|) a b :== tbind a (\_ -> b)
myExp = (Size (New [1,2,3] +. Elem 2))
//Start = let (Sem f) = (eval myExp) in f ('Map'.newMap)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment