Commit 39b612a8 authored by Reg Huijben's avatar Reg Huijben

Nearly complete w10

parent 554f532f
module w10reg
/*
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 Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
from Data.Set import instance == (Set a), instance < (Set a), instance Foldable Set
from Text.GenJSON import JSONEncode
derive class iTask State
derive class iTask Stmt
derive class iTask Expression
derive class iTask Logical
derive class iTask Val
derive class iTask Res
derive JSONEncode Map
derive JSONDecode Map
// use this as: 'List'.union
// ================ the DSL ===============
:: Expression
= New [Int]
| Elem Int
| Variable Ident
| Size SetA
| (+.) infixl 6 Expression Expression
| (-.) infixl 6 Expression Expression
| (*.) infixl 7 Expression Expression
| (=.) infixl 2 Ident Expression
:: Logical
= TRUE | FALSE
| (In) infix 4 Elem SetA
| (==.) 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 SetA Stmt
| If Logical Stmt Stmt
:: SetA :== Expression
:: Elem :== Expression
:: Ident :== String
// === State
:: Val = I Int | SetA [Int]//('iTasks'.Set Int)
:: State = State (Map Ident Val)
// === semantics
:: Res a = Res a | Err String
:: Sem a = Sem (State -> (Res a, State))
instance Functor Sem where
fmap f (Sem g) = Sem \s.case g s of
(Res a,s) = (Res (f a), s)
(Err e,s) = (Err e, s)
instance <*> Sem where
(<*>) (Sem f) (Sem g)
= Sem \s.case f s of
(Res f, s) = case g s of
(Res a,s) = (Res (f a),s)
(Err e, s) = (Err e, s)
(Err e,s) = (Err e,s)
unres :: (Sem a) -> (State -> (Res a, State))
unres (Sem f) = f
instance Monad Sem where // !(m a) (a -> m b) -> m b
bind (Sem f) g = Sem \s. case f s of
(Res a, s) = unres (g a) s
(Err e, s) = (Err e, s)
instance pure Sem where
pure a = Sem \s.(pure a, s)
instance pure Res where
pure a = (Res a)
fromMaybe :: (Maybe a) -> (Res a)
fromMaybe (Just a) = Res a
fromMaybe (Nothing) = Err "ERROR while getting from state"
store :: Ident Val -> Sem Val
store i v = Sem \(State mp). (pure v, State ('Map'.put i v mp))
read :: Ident -> Sem Val
read i = Sem \(State mp).(fromMaybe ('Map'.get i mp), State mp)
fail :: String -> Sem a
fail str = Sem \s.(Err str, 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 (Elem i) = pure (I i)
//eval (New i) = pure (map 'List'.union i)//(Set ('List'.union i))
eval (New list) = pure (SetA ('Set'.toList ('Set'.fromList list)))
eval (+. e1 e2) = eval e1 >>= \a1.
eval e2 >>= \a2.
case a1 of
I a1 -> case a2 of
I a2 -> pure (I (a1 + a2))
SetA s1 -> pure (SetA ('Set'.toList ( 'Set'.union ('Set'.singleton a1) ('Set'.fromList s1) )))
SetA s1 -> case a2 of
SetA s2 -> pure (SetA ('Set'.toList ('Set'.union ('Set'.fromList s1) ('Set'.fromList s2))))
I a2 -> pure (SetA ('Set'.toList ('Set'.union ('Set'.fromList s1) ('Set'.singleton a2))))
eval (-. e1 e2) = eval e1 >>= \a1.
eval e2 >>= \a2.
case a1 of
I a1 -> case a2 of
I a2 -> pure (I (a1 - a2))
SetA s1 -> fail "Cannot subtract set from int"
SetA s1 -> case a2 of
SetA s2 -> pure (SetA ('Set'.toList ('Set'.difference ('Set'.fromList s1) ('Set'.fromList s2))))
I a2 -> pure (SetA ('Set'.toList ('Set'.difference ('Set'.fromList s1) ('Set'.singleton a2))))
eval (*. e1 e2) = eval e1 >>= \a1.
eval e2 >>= \a2. case a1 of
I a1 -> case a2 of
I a2 -> pure (I (a1 * a2))
SetA s1 -> pure (SetA ('Set'.toList (ourMap (a1) ('Set'.fromList s1))))
SetA s1 -> case a2 of
SetA s2 -> pure (SetA ('Set'.toList ('Set'.intersection ('Set'.fromList s1) ('Set'.fromList s2))))
I a2 -> fail "Set *. Int is impossible"
eval (=. id expr) = eval expr >>= \val. store id val
eval (Variable id) = read id
eval (Size e) = eval e >>= \a.case a of
I i -> fail "Can't have size of number"
SetA s -> pure (I (length s))
//eval a = fail "not implemented"
logiceval :: Logical -> Sem Bool
logiceval TRUE = pure (True)
logiceval FALSE = pure (False)
logiceval (In e s) = eval e >>= \elem. case elem of
(I af) -> eval s >>= \st. case st of
SetA s -> pure ('Set'.member af ('Set'.fromList s))
_ -> fail "Can only check for element in a set"
_ -> fail "Can not check for a set in a set"
// | (In) infix 4 Elem Set
// | (==.) infix 4 Expression Expression
logiceval (==. a b) = eval a >>= \aa.
eval b >>= \bb.
case aa of
I a ->
case bb of
I b -> pure (a == b)
SetA b -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
SetA a -> case bb of
SetA b -> pure (a == b)
I _ -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
//eval b >>= \bb.
// | (<=.) infix 4 Expression Expression
logiceval (<=. a b) = eval a >>= \aa.
eval b >>= \bb.
case aa of
I a ->
case bb of
I b -> pure (a <= b)
SetA b -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
SetA a -> case bb of
SetA b -> pure (a <= b)
I _ -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
// | Not Logical
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 :: Stmt -> Sem ()
stmteval (Expression expr) = eval expr >>= \e. pure ()
stmteval (Logical l) = logiceval l >>= \e. pure ()
stmteval (If l st1 st2) = logiceval l >>= \e. if e
(stmteval st1)
(stmteval st2)
stmteval (For id st stmt) = eval st >>= \s. case s of
I _ -> fail "f"
SetA s -> pure (\ elem. (store id (I elem))) >>= \e.pure ()
// === 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
// Set s -> pure (map (\ elem. (store id (I elem)) >>= \e.pure (stmteval stmt) ) ('Set'.toList s)) >>= \e.pure ()
/*eval (*. e1 e2) = eval e1 >>= \a1.
eval e2 >>= \a2.
case a1 of
I a1 -> case a2 of
I a2 -> pure (I (a1 * a2))
Set s1 -> pure (Set ('Set'.difference s1 ('Set'.singleton a2)))
Set s1 -> case a2 of
Set s2 -> pure (Set ('Set'.intersection s1 s2))
I a2 -> fail "Cannot subtract set from int"
*/
/*
eval (-. e1 e2) = eval e1 >>= \a1.
eval e2 >>= \a2.
case a1 of
I a1 -> case a2 of
I a2 -> pure (I (a1 - a2))
Set s1 -> fail "Oof, we cannot remove a set from an element"
Set s1 -> case a2 of
Set s2 -> fail "impl missing"//pure (Set (s1 ++ s2))
I a2 -> fail "impl missing"//pure (Set (a2:s1))
*/
//:: Sem a = Sem (State -> (Res a, State))
//eval (+. e1 e2) = (eval e1)
// !(m a) (a -> m b) -> m b
// (I (a1+a2)))
//(eval e1) >>= \Sem s. I 1 //\Sem s1. (eval e2) >>= \Sem s2. (Just (e1))
/*case (eval e1) of
(I i1) -> case (eval e2) of
I i2 -> pure (I (i1+i2))
Set s -> fail "Cannot add int and set"
(Set s1) -> case (eval e2) of
I i -> fail "Cannot add set and int"
Set s2 -> pure (Set (s1+s2))
*/
//eval (+. e1 e2) = pure (I ((eval e1) + (eval e2)))
//eval (+. (Elem e1) (Elem e2)) = pure (I (e1 + e2))
//eval (+. e1 e2) = fail "Cannot add"
anexpr = Elem 1
anotherexpr = Elem 1 +. Elem 1
//Start = let (State f) = (eval anexpr) in 'Map'.newMap >>= f
anotherexpr1 = Elem 1 +. New [1]
anotherexpr2 = (New [2] +. ("henk" =. Elem 9) ) -. Variable "henk" //(New [4,5,6] +. Elem 7 +. Elem 7) -. Elem 7
stt :: Stmt
stt = If (Variable "a" ==. (Elem 9)) (Expression ("henk" =. Elem 9)) (Expression (Elem 2))
aSet :: Expression
aSet = New [0,1,9]
astmt :: Stmt
//astmt = If FALSE (Expression anotherexpr2) (Expression ("henk" =. Elem 10))
astmt = For "a" aSet stt
//Start = let (Sem f) = (eval anotherexpr2) in f (State 'Map'.newMap)
//Start = let (Sem f) = (stmteval astmt) in f (State 'Map'.newMap)
//f = 'Set'.toList ('Set'.fromList [1])
// res : ((Err "Cannot add int with set"),(State Tip))
// of //'Map'.newMap >>= f
// === simulation
//derive JSONEncode Set
//'derive JSONDecode Set
//derive class iTask 'iTasks'.Set
//derive class iTask Map String Val
//derive class iTask (Map Ident Val)
//:: Sem a = Sem (State -> (Res a, State))
(>>>=) :== tbind
(>>>|) a b :== tbind a (\_ -> b)
//evl e = let (Sem f) = (eval e) in f (State 'Map'.newMap)
//myFTask :: Task (Res Val)
//myFTask = enterInformation [] >>>= (\ex. let (res, stat) = (evl ex) in viewInformation [] res ) //viewInformation []
//(res, stat) = (f (State 'Map'.newMap))
evl :: Expression State -> (Res Val,State)
evl e s = let (Sem f) = (eval e) in f s
//loopert s = enterInformation [] >>>= (\ex. let (res, stat) = (evl2 ex s) in (viewInformation [] res) >>>= (loopert stat) )
emptyState = State 'Map'.newMap
loopert :: State (Maybe (Res Val)) (Maybe Expression) -> Task String//(Expression)
//loopert s prv =( (Title "Edit" @>> enterInformation [] >>>= (\ex. let (res, stat) = (evl2 ex s) in (loopert stat (Just res)) ) )
loopert prev_state prev_res prev_expr = ( (Title "Edit" @>> enterInformation [] )
-|| (Title "Pretty print" @>> viewInformation [] case prev_expr of
(Just prev_expr) -> (print prev_expr)
Nothing -> "")
-|| (Title "Result" @>> viewInformation [] prev_res)
-|| (Title "Result state" @>> viewInformation [] prev_state)
)
>>* [ OnAction (Action "Add") (hasValue (\ex. let (res, stat) = (evl ex prev_state) in (loopert stat (Just res) (Just ex)) ))
, OnAction (Action "Reset state") (always ( (loopert emptyState prev_res prev_expr) ))
, OnAction (Action "Quit") (always ( treturn "Goodbye"))
//, OnAction ActionCancel (always (return []))
]
//loopert s = enterInformation [] >>>= (\ex. let (res, stat) = (evl2 ex s) in (viewInformation [] res) )
Start world = doTasks ((loopert emptyState Nothing Nothing ) >>>= \s. viewInformation [] s) world
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