*.o
test
gopt
+afp/a[0-9]/a[0-9]
--- /dev/null
+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)
+ @! ()
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
repositories / clean-tests.git / commitdiff