From 85be4012fc8ee04ef900d0586f84a00af8aa7862 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Wed, 14 Nov 2018 10:43:18 +0100 Subject: [PATCH] fundeps a8 --- .gitignore | 1 + afp/a6/a7.icl | 170 +++++++++++++++++++++++++++++++++++++++ afp/a8/a8.icl | 179 ++++++++++++++++++++++++++++++++++++++++++ afp/a8/a8_old.icl | 165 ++++++++++++++++++++++++++++++++++++++ parserParser/test.icl | 45 +++++++++++ 5 files changed, 560 insertions(+) create mode 100644 afp/a6/a7.icl create mode 100644 afp/a8/a8.icl create mode 100644 afp/a8/a8_old.icl create mode 100644 parserParser/test.icl diff --git a/.gitignore b/.gitignore index 407ad86..6938473 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ getopt *.o test gopt +afp/a[0-9]/a[0-9] diff --git a/afp/a6/a7.icl b/afp/a6/a7.icl new file mode 100644 index 0000000..b55361c --- /dev/null +++ b/afp/a6/a7.icl @@ -0,0 +1,170 @@ +module a7 + +import StdEnv + +import qualified Data.List as List +import Data.Func +import Control.Applicative + +import iTasks + +:: Job = + { id :: Int + , jobName :: String + , skills :: [Skill] + , blocked :: Bool + , children :: [Job] + } +:: Skill = Programming | Design | Testing +:: Worker = + { username :: String + , password :: String + , skills :: [Skill] + , loggedIn :: Bool + } +instance == Worker where == w1 w2 = w1.Worker.username == w2.Worker.username +instance == Skill where == s1 s2 = s1 === s2 +instance == Job where == s1 s2 = s1.jobName == s2.jobName +derive class iTask Worker, Skill, Job +derive JSONEncode Set +derive JSONDecode Set +derive gText Set +derive gEditor Set +derive gDefault Set + +usersStore :: Shared [Worker] +usersStore = sharedStore "Users" [{Worker|username="mart",password="mart",loggedIn=False,skills=[Design,Testing]}] +userStore :: String -> Shared Worker +userStore u = mapReadWriteError + (\wl->case filter (\w->w.Worker.username == u) wl of + [u] = Ok u + u = Error (exception ("worker not found: " +++ toSingleLineText u)) + ,\nw wl->Ok $ Just [nw:filter (\w->w.Worker.username <> u) wl] + ) usersStore + +jobsStore :: Shared [Job] +jobsStore = sharedStore "Jobs" + [{id=1,jobName="Testing",skills=[Testing],children=[],blocked=False} + ,{id=2,jobName="Bigjob",skills=[Testing],blocked=False,children= + [{id=3,jobName="subjob1",skills=[Testing],children=[],blocked=False} + ,{id=4,jobName="subjob1",skills=[Testing],children=[],blocked=False} + ]} + ] +jobStore :: Int -> Shared Job +jobStore i = mapReadWriteError + (findJob i + ,\nj jl->Ok $ Just $ map (updateJob nj) jl + ) jobsStore +where + findJob i [] = Error (exception "Job not found") + findJob i [j=:{Job|id}:_] | id == i = Ok j + findJob i [j:js] = case findJob i j.Job.children of + Error e = findJob i js + Ok u = Ok u + + updateJob nj j=:{Job|id} | id == i = nj + updateJob nj j = {Job|j & children=map (updateJob nj) j.Job.children} + +removeJob :: Int [Job] -> [Job] +removeJob i [] = [] +removeJob i [j=:{Job|id}:js] | i == id = js +removeJob i [j:js] = [{Job|j & children=removeJob i j.Job.children}:removeJob i js] + +jobID :: Shared Int +jobID = sharedStore "JobIDS" 4 + +Start w = doTasks ((login -||- register <<@ ArrangeWithTabs False) >>- work) w + +register :: Task Worker +register = tune (Title "Register") + $ enterInformation "Enter credentials" [EnterUsing id credentialEditor] + -&&- enterInformation "Enter Skills" [] + >>= \((u, p),s)->get usersStore + @ filter (\a->a.Worker.username==u) + >>- \exists->case exists of + [] = let user = {loggedIn=True,username=u,password=p,skills=removeDup s} + in upd (\l->[user:l]) usersStore >>| treturn user + _ = viewInformation "User already exists" [] () >>| register + +login :: Task Worker +login = tune (Title "Login") + $ enterInformation "Enter credentials" [EnterUsing id credentialEditor] + >>= \(u,p)->get usersStore + @ filter (\a->a.Worker.username==u && a.Worker.password==p) + >>- \u->case u of + [] = viewInformation "User not found or incorrect password" [] () >>| login + [{loggedIn=True}] = viewInformation "User is already logged in" [] () >>| login + [u] = upd (\w->{w & loggedIn=True}) (userStore u.Worker.username) + +credentialEditor = panel2 + (textField <<@ labelAttr "Username") + (passwordField <<@ labelAttr "Password") + +work :: Worker -> Task [()] +work {Worker|username} = allTasks + [ viewJobs + , createNewJobs + , updateSkills + ] <<@ Title ("Welcome " +++ username) <<@ ArrangeWithTabs False +where + viewJobs + = tune (Title "View jobs") + $ editSelectionWithShared "Select a job" False + (SelectInTree toCN fromSel) + (jobsStore >*< userStore username) + (\_->[]) + >^* + [OnAction (Action "Execute") $ ifValue (\j->j=:[_]) \[j]-> + upd (\j->{j & blocked=True}) (jobStore j.Job.id) + >>| viewSharedInformation "Job" [] (jobStore j.Job.id) + >>* + [OnAction (Action "Finish") $ always $ + upd (removeJob j.Job.id) jobsStore + ,OnAction (Action "Split") $ always $ + enterInformation "Enter sub jobs" [EnterUsing id (gEditor{|*->*|} jobEditor gText{|*|} JSONEncode{|*|} JSONDecode{|*|})] + >>= \sjs->sequence (take (length sjs) (repeat (upd inc jobID))) + >>= \ids->upd (\j->{Job|j & blocked=False,children=[{Job|id=i,jobName=n,skills=s,blocked=False,children=[]}\\(n,s)<-sjs & i<-ids]}) (jobStore j.Job.id) + @! [] + ,OnAction (Action "Cancel") $ always $ + upd (\j->{j & blocked=False}) (jobStore j.Job.id) + @! [] + ] + ] + @! () + + toCN ::([Job],Worker) -> [ChoiceNode] + toCN (jobs, worker) = + [ + {id=if (job.Job.blocked || not (job.Job.children =: []) || not (matchSkills job)) (~job.Job.id) job.Job.id + ,label=job.Job.jobName +++ "(" +++ toSingleLineText job.Job.skills +++ ")" + ,icon=if (job.Job.blocked || not (matchSkills job)) (Just "document-error") Nothing + ,expanded=True + ,children=toCN (job.Job.children, worker) + } + \\job<-jobs + ] + where + matchSkills job = 'List'.difference job.Job.skills worker.Worker.skills == [] + + fromSel :: ([Job],Worker) [Int] -> [Job] + fromSel (jobs,w) ids + = [j\\j<-jobs | isMember j.Job.id ids] + ++ flatten [fromSel (j.Job.children, w) ids\\j<-jobs] + + createNewJobs + = tune (Title "Create new jobs") + $ forever + $ enterInformation "Enter job" [EnterUsing id jobEditor] + >>= \(name, skills)->upd inc jobID + >>= \i->upd ((++) [{Job|id=i,skills=skills,jobName=name,blocked=False,children=[]}]) jobsStore + @! () + + jobEditor :: Editor (String, [Skill]) + jobEditor = panel2 + (gEditor{|*|} <<@ labelAttr "Name") + (gEditor{|*|} <<@ labelAttr "Skills") + + updateSkills + = tune (Title "Edit skills") + $ updateSharedInformation "Skills" [UpdateAs (\w->w.Worker.skills) (\w s->{Worker|w & skills=s})] (userStore username) + @! () diff --git a/afp/a8/a8.icl b/afp/a8/a8.icl new file mode 100644 index 0000000..95e679d --- /dev/null +++ b/afp/a8/a8.icl @@ -0,0 +1,179 @@ +module a8 + +/* + Advanced Progrmming 2018, Assignment 8 + Pieter Koopman, pieter@cs.ru.nl +*/ +import StdEnv + +import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans +import Data.Func +import Data.Functor +import Data.Either +import Data.Maybe + +import Text => qualified join + +import qualified Data.List as List +import qualified Data.Map as Map + +:: 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 :== Either Int [Int] +:: SemState :== 'Map'.Map String Val +:: Sem a :== StateT SemState (Either String) a + +store :: Ident Val -> Sem Val +store k v = modify ('Map'.put k v) *> pure v + +read :: Ident -> Sem Val +read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure + +fail :: String -> Sem a +fail s = liftT (Left s) + +// === semantics +isset :: (Sem Val) -> Sem [Int] +isset s = s >>= either (\_->fail "Expected Set, got Elem") pure + +iselem :: (Sem Val) -> Sem Int +iselem s = s >>= either pure (\_->fail "Expected Elem, got Set") + +class eval t ~v :: t -> Sem v + +instance eval Expression Val +where + eval :: Expression -> Sem Val + eval (New s) = pure $ Right s + eval (Elem i) = pure $ Left i + eval (Variable i) = read i + eval (Size s) = isset (eval s) >>= pure o Left o length + eval (l +. r) = eval l >>= \x->eval r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x + y) + (Left x, Right y) = pure $ Right $ 'List'.union [x] y + (Right x, Left y) = pure $ Right $ 'List'.union x [y] + (Right x, Right y) = pure $ Right $ 'List'.union x y + eval (l -. r) = eval l >>= \x->eval r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x - y) + (Left x, Right y) = fail "Elem -. Set is illegal" + (Right x, Left y) = pure $ Right $ 'List'.intersect x [y] + (Right x, Right y) = pure $ Right $ 'List'.intersect x y + eval (l *. r) = eval l >>= \x->eval r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x * y) + (Left x, Right y) = pure $ Right [x*y\\y<-y] + (Right x, Left y) = fail "Set *. Elem is illegal" + (Right x, Right y) = pure $ Right $ 'List'.intersect x y + eval (v =. b) = eval b >>= store v + +instance eval Logical Bool +where + eval TRUE = pure True + eval FALSE = pure False + eval (e In s) = liftM2 'List'.elem (iselem (eval e)) (isset (eval s)) + eval (e1 ==. e2) = liftM2 (===) (eval e1) (eval e2) + eval (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of + (Left e1, Left e2) = pure $ e1 < e2 + (Left e1, Right e2) = pure $ True + (Right e1, Left e2) = pure $ False + (Right e1, Right e2) = pure $ length e1 < length e2 + where + evalExpr :: (Expression -> Sem Val) + evalExpr = eval + eval (Not l) = not <$> eval l + eval (l1 ||. l2) = liftM2 (||) (eval l1) (eval l2) + eval (l1 &&. l2) = liftM2 (&&) (eval l1) (eval l2) + +instance eval Stmt () +where + eval (Expression e) = eval e >>| pure () + eval (Logical l) = eval l >>| pure () + eval (For i e s) = (eval e >>= store i) *> eval s + eval (If l s1 s2) = eval l >>= \b->if b (eval s1) (eval s2) + +class print t :: t [String] -> [String] +instance print Expression +where + print (New s) c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c] + print (Elem i) c = [toString i:c] + print (Variable i) c = [i:c] + print (Size s) c = ["size(":print s [")":c]] + print (l +. r) c = ["(":print l ["+.":print r [")":c]]] + print (l -. r) c = ["(":print l ["-.":print r [")":c]]] + print (l *. r) c = ["(":print l ["*.":print r [")":c]]] + print (l =. r) c = [l,"=.":print r c] + +instance print Logical +where + print TRUE c = ["True":c] + print FALSE c = ["False":c] + print (e In s) c = print e [" in ":print s c] + print (e1 ==. e2) c = ["(":print e1 ["==.":print e2 [")":c]]] + print (e1 <=. e2) c = ["(":print e1 ["<=.":print e2 [")":c]]] + print (Not l) c = ["not (":print l [")":c]] + print (l1 ||. l2) c = ["(":print l1 ["||.":print l2 [")":c]]] + print (l1 &&. l2) c = ["(":print l1 ["&&.":print l2 [")":c]]] + +instance print Stmt +where + print (Expression e) c = print e c + print (Logical l) c = print l c + print (For i e s) c = ["For ",i,"=":print e ["in":print s ["Rof":c]]] + print (If l s1 s2) c = ["If":print l ["then":print s1 ["else":print s2 ["Fi":c]]]] + +// === simulation +stateShared :: Shared SemState +stateShared = sharedStore "sharedSemState" 'Map'.newMap + +derive class iTask Expression, Logical, Stmt + +main :: Task SemState +main = 'iTasks'.forever $ + enterInformation "Enter a statement" [] + -|| viewSharedInformation "Old state" [ViewAs printer] stateShared + >&^ viewSharedInformation "Print" [ViewAs viewer] + >&> viewSharedInformation "New state" [ViewAs $ fmap printer] o mapRead evaler o ((>*<) stateShared) + >>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared] +where + viewer = maybe + "No expression selected" + ('Text'.join " " o flip print []) + evaler :: (SemState, Maybe Stmt) -> Either String SemState + evaler (s, t) = maybe + (Left "No expression selected") + (\e->execStateT (eval e) s) t + printer m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m] + +Start w = doTasks main w diff --git a/afp/a8/a8_old.icl b/afp/a8/a8_old.icl new file mode 100644 index 0000000..f5bbc32 --- /dev/null +++ b/afp/a8/a8_old.icl @@ -0,0 +1,165 @@ +module a8 + +/* + Advanced Progrmming 2018, Assignment 8 + Pieter Koopman, pieter@cs.ru.nl +*/ +import StdEnv + +import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans +import Data.Func +import Data.Functor +import Data.Either +import Data.Maybe + +import Text => qualified join + +import qualified Data.List as List +import qualified Data.Map as Map + +:: 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 :== Either Int [Int] +:: SemState :== 'Map'.Map String Val + +:: Sem a :== StateT SemState (Either String) a +store :: Ident Val -> Sem Val +store k v = modify ('Map'.put k v) *> pure v + +read :: Ident -> Sem Val +read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure + +fail :: String -> Sem a +fail s = liftT (Left s) + +// === semantics +isset :: (Sem Val) -> Sem [Int] +isset s = s >>= either (\_->fail "Expected Set, got Elem") pure + +iselem :: (Sem Val) -> Sem Int +iselem s = s >>= either pure (\_->fail "Expected Elem, got Set") + +evalExpr :: Expression -> Sem Val +evalExpr (New s) = pure $ Right s +evalExpr (Elem i) = pure $ Left i +evalExpr (Variable i) = read i +evalExpr (Size s) = isset (evalExpr s) >>= pure o Left o length +evalExpr (l +. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x + y) + (Left x, Right y) = pure $ Right $ 'List'.union [x] y + (Right x, Left y) = pure $ Right $ 'List'.union x [y] + (Right x, Right y) = pure $ Right $ 'List'.union x y +evalExpr (l -. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x - y) + (Left x, Right y) = fail "Elem -. Set is illegal" + (Right x, Left y) = pure $ Right $ 'List'.intersect x [y] + (Right x, Right y) = pure $ Right $ 'List'.intersect x y +evalExpr (l *. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of + (Left x, Left y) = pure $ Left (x * y) + (Left x, Right y) = pure $ Right [x*y\\y<-y] + (Right x, Left y) = fail "Set *. Elem is illegal" + (Right x, Right y) = pure $ Right $ 'List'.intersect x y +evalExpr (v =. b) = evalExpr b >>= store v + +evalLogic :: Logical -> Sem Bool +evalLogic TRUE = pure True +evalLogic FALSE = pure False +evalLogic (e In s) = liftM2 'List'.elem (iselem (evalExpr e)) (isset (evalExpr s)) +evalLogic (e1 ==. e2) = liftM2 (===) (evalExpr e1) (evalExpr e2) +evalLogic (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of + (Left e1, Left e2) = pure $ e1 < e2 + (Left e1, Right e2) = pure $ True + (Right e1, Left e2) = pure $ False + (Right e1, Right e2) = pure $ length e1 < length e2 +evalLogic (Not l) = not <$> evalLogic l +evalLogic (l1 ||. l2) = liftM2 (||) (evalLogic l1) (evalLogic l2) +evalLogic (l1 &&. l2) = liftM2 (&&) (evalLogic l1) (evalLogic l2) + +evalStmt :: Stmt -> Sem () +evalStmt (Expression e) = evalExpr e >>| pure () +evalStmt (Logical l) = evalLogic l >>| pure () +evalStmt (For i e s) = (evalExpr e >>= store i) *> evalStmt s +evalStmt (If l s1 s2) = evalLogic l >>= \b->if b (evalStmt s1) (evalStmt s2) + +printExpr :: Expression [String] -> [String] +printExpr (New s) c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c] +printExpr (Elem i) c = [toString i:c] +printExpr (Variable i) c = [i:c] +printExpr (Size s) c = ["size(":printExpr s [")":c]] +printExpr (l +. r) c = ["(":printExpr l ["+.":printExpr r [")":c]]] +printExpr (l -. r) c = ["(":printExpr l ["-.":printExpr r [")":c]]] +printExpr (l *. r) c = ["(":printExpr l ["*.":printExpr r [")":c]]] +printExpr (l =. r) c = [l,"=.":printExpr r c] + +printLogic :: Logical [String] -> [String] +printLogic TRUE c = ["True":c] +printLogic FALSE c = ["False":c] +printLogic (e In s) c = printExpr e [" in ":printExpr s c] +printLogic (e1 ==. e2) c = ["(":printExpr e1 ["==.":printExpr e2 [")":c]]] +printLogic (e1 <=. e2) c = ["(":printExpr e1 ["<=.":printExpr e2 [")":c]]] +printLogic (Not l) c = ["not (":printLogic l [")":c]] +printLogic (l1 ||. l2) c = ["(":printLogic l1 ["||.":printLogic l2 [")":c]]] +printLogic (l1 &&. l2) c = ["(":printLogic l1 ["&&.":printLogic l2 [")":c]]] + +printStmt :: Stmt [String] -> [String] +printStmt (Expression e) c = printExpr e c +printStmt (Logical l) c = printLogic l c +printStmt (For i e s) c = ["For ",i,"=":printExpr e ["in":printStmt s ["Rof":c]]] +printStmt (If l s1 s2) c = ["If":printLogic l ["then":printStmt s1 ["else":printStmt s2 ["Fi":c]]]] + +// === simulation +stateShared :: Shared SemState +stateShared = sharedStore "sharedSemState" 'Map'.newMap + +derive class iTask Expression, Logical, Stmt + +main :: Task SemState +main = 'iTasks'.forever $ + enterInformation "Enter a statement" [] + -|| viewSharedInformation "Old state" [ViewAs printState] stateShared + >&^ viewSharedInformation "Print" [ViewAs viewer] + >&> viewSharedInformation "New state" [ViewAs $ fmap printState] o mapRead evaler o ((>*<) stateShared) + >>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared] +where + viewer = maybe + "No expression selected" + ('Text'.join " " o flip printStmt []) + evaler (s, t) = maybe + (Left "No expression selected") + (\e->execStateT (evalStmt e) s) t + printState m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m] + +Start w = doTasks main w diff --git a/parserParser/test.icl b/parserParser/test.icl new file mode 100644 index 0000000..5eb04d6 --- /dev/null +++ b/parserParser/test.icl @@ -0,0 +1,45 @@ +module test + +import StdEnv + +import Data.Functor +import Control.Applicative +import Control.Monad +import Control.Monad.State + +import Text.Parsers.Simple.Core + +:: In a b = (:.) infix 0 a b + +:: Gram + = Def (Gram -> In Gram Gram) + | Def2 ((Gram,Gram) -> In (Gram, Gram) Gram) + | Lit String + | Int + | (-.) infixr 2 Gram Gram + | (|.) infix 1 Gram Gram +:: Gast + = INT Int + | LIT String + | BIN Gast Gast + +parseFromGram :: Gram -> Parser String Gast +parseFromGram (Def g) = let (body :. gram) = g body in parseFromGram gram +parseFromGram Int = INT o toInt <$> pSatisfy (\s->toString (toInt s) == s) +parseFromGram (Lit i) = LIT <$> pSatisfy ((==)i) +parseFromGram (a -. b) = BIN <$> parseFromGram a <*> parseFromGram b +parseFromGram (a |. b) = parseFromGram a <|> parseFromGram b + +//Start = runParser (parseFromGram gram) [".","."] +Start = parse (parseFromGram gram) ["5"] +where + gram = + Def \lit = Int + |. Lit "(" -. expr -. Lit ")" + Def \fac = lit -. Lit "*" -. fac + |. lit -. Lit "/" -. fac + |. lit :. + Def \expr= fac -. Lit "+" -. expr + |. fac -. Lit "-" -. expr + |. fac :. + expr -- 2.20.1