Commit 99741333 authored by Rinus Plasmeijer's avatar Rinus Plasmeijer

adjusted iTask examples to new system

there is a list of small problems to solve

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@295 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 185e35e9
module coffeemachine
// (c) MJP 2007
//
// This is a demo of a coffeemachine programmed with iTasks combinators.
// The persistent variant remembers the state in which the coffee machine was left.
// Garbage collection of unused tasks is done automatically.
// Some alternative coffee machine definitions have been added as example for the ICFP07 paper.
import StdEnv, StdiTasks, iDataTrivial
Start world = startTaskEngine (foreverTask CoffeeMachine) world
CoffeeMachine :: Task (String,Int)
CoffeeMachine
= chooseTask [Text "Choose product:",Br,Br]
[("Coffee: 100", return_V (100,"Coffee"))
,("Cappucino: 150", return_V (150,"Cappucino"))
,("Tea: 50", return_V (50, "Tea"))
,("Chocolate: 100", return_V (100,"Chocolate"))
]
=>> \(toPay,product) -> [Text ("Chosen product: " <+++ product),Br,Br]
?>> getCoins (toPay,0)
=>> \(cancel,returnMoney) ->let nproduct = if cancel "Cancelled" product in
[Text ("product = " <+++ nproduct <+++ ", returned money = " <+++ returnMoney),Br,Br]
?>> buttonTask "Thanks" (return_V (nproduct,returnMoney))
getCoins :: (Int,Int) -> Task (Bool,Int)
getCoins (cost,paid) = getCoins`
where
getCoins`
= chooseTask [Text ("To pay: " <+++ cost),Br,Br]
[(c +++> " cents", return_V (False,c)) \\ c <- coins]
-||-
buttonTask "Cancel" (return_V (True,0))
=>> handleMoney
handleMoney (cancel,coin)
| cancel = return_V (cancel, paid)
| cost > coin = getCoins (cost-coin,paid+coin)
| otherwise = return_V (cancel, coin-cost)
coins = [5,10,20,50,100,200]
// getCoins2 is alternative definition of getCoins, but uses repeatTask instead of direct recursion
getCoins2 :: ((Bool,Int,Int) -> Task (Bool,Int,Int))
getCoins2 = repeatTask get (\(cancel,cost,paid) -> cancel || cost <= 0)
where
get (cancel,cost,paid)
= chooseTask[Text ("To pay: " <+++ cost),Br,Br]
[(c +++> " cents", return_V (False,c)) \\ c <- coins]
-||-
buttonTask "Cancel" (return_V (True,0))
=>> \(cancel,c) -> return_V (cancel,cost-c,paid+c)
coins = [5,10,20,50,100,200]
// for the ICFP07 paper: a single step coffee machine
singleStepCoffeeMachine :: Task (String,Int)
singleStepCoffeeMachine
= chooseTask [Text "Choose product:",Br,Br]
[(p<+++": "<+++c, return_V prod) \\ prod=:(p,c)<-products]
=>> \prod=:(p,c) -> [Text ("Chosen product: "<+++p),Br,Br]
?>> pay prod (buttonTask "Thanks" (return_V prod))
where
products = [("Coffee",100),("Tea",50)]
// version using labeled action:
// pay (p,c) t = buttonTask ("Pay "<+++c<+++ " cents") t
// version using getCoins:
/* pay (p,c) t = getCoins (c,0) =>> \(cancel,returnMoney) ->
[Text ("Product = "<+++if cancel "cancelled" p
<+++". Returned money = "<+++returnMoney),Br,Br]
?>> t
*/
// version using getCoins2:
pay (p,c) t = getCoins2 (False,c,0) =>> \(cancel,_,paid) ->
if cancel [Text ("Cancelled. Your money = "<+++paid),Br,Br]
[Text ("Product = "<+++p<+++". Returned money ="<+++(paid-c)),Br,Br]
?>> t
// A very simple coffee machine
SimpleCoffee :: Task Void
SimpleCoffee
= chooseTask [Text "Choose product:",Br,Br]
[("Coffee", return_V ("Coffee"))
,("Tea", return_V ("Tea"))
]
=>> \(product) -> [Text ("Enjoy your " <+++ product)]
?>> buttonTask "OK" (return_V Void)
// and another one
SimpleCoffee2 :: Task Void
SimpleCoffee2
= chooseTask [Text "Choose product:",Br,Br]
[("Coffee: 20", return_V (20,"Coffee"))
,("Tea: 10", return_V (10,"Tea"))
]
=>> \(toPay,product) -> payDimes toPay
#>> [Text ("Enjoy your " <+++ product)]
?>> buttonTask "OK" (return_V Void)
where
payDimes 0 = return_V Void
payDimes n = buttonTask "10 cts" (return_V Void)
#>> payDimes (n - 10)
Br = BrTag []
\ No newline at end of file
This diff is collapsed.
module marking
// This example show how marks can be given by people logged in
// The marks are intended for user 0 who can show them
// (c) mjp 2007/2008
import StdEnv, StdiTasks, iDataTrivial
//import iTaskUtil
derive gForm Mark, []
derive gUpd Mark, []
derive gParse Mark
derive gPrint Mark
derive gerda Mark
derive read Mark
derive write Mark
:: Mark = {userName :: String, loginId :: Int, mark :: Int, comment :: String}
Start world = startTaskEngine (marking 0 "manager") world
marking i accountname = [Text ("Welcome user " <+++ accountname),BrTag [],BrTag []] !>> respond i accountname
where
respond uniqueId name
= spawnWorkflow uniqueId True ("Give Mark", foreverTask (giveMark uniqueId name))
#>> spawnWorkflow uniqueId True ("Give Comment", foreverTask (giveComment uniqueId name))
#>> foreverTask show
show
= readMarksDB
=>> \marks -> [ Text "Here are the scores given by the users:", BrTag [], BrTag []
, STable [BorderAttr (toString 1)] [[Text (toString (number i marks)) \\ i <- [0..10]]
,[BTag [] [Text (toString i)] \\ i <- [0..10]]
]
, BrTag [], BrTag []
, HrTag []
, Text (foldl (+++) "" [m.userName +++ " : " +++ m.comment +++ " +++ " \\ m <- marks ])
, HrTag []
] ?>> Confirm "Refresh"
where
number i marks = length [n\\n <- marks | n.mark == i]
giveMark uniqueId name
= readMyMarksDB uniqueId
=>> \(mark,comment) -> [ Text ("Previous mark given:" <+++ if (mark == -1) "No mark given" (toString mark)), BrTag [], BrTag []
, Text "Give your new mark (0 = lowest, 10 = highest)", BrTag [], BrTag []]
?>> chooseTask [] [(toString i,return_V i) \\ i <- [0..2]] -||-
chooseTask [] [(toString i,return_V i) \\ i <- [3..5]] -||-
chooseTask [] [(toString i,return_V i) \\ i <- [6..8]] -||-
chooseTask [] [(toString i,return_V i) \\ i <- [9..10]]
=>> \mark -> readMyMarksDB uniqueId
=>> \(_,comment) -> writeMarksDB {userName = name, loginId = uniqueId, mark = mark, comment = comment}
#>> [Text ("Your mark " <+++ mark <+++ " has been stored!"),BrTag [],BrTag []]
?>> OK
giveComment uniqueId name
= readMyMarksDB uniqueId
=>> \(mark,comment) -> [ Text "Previous comment given:", BrTag [], BrTag []
, Text (if (comment == "" ) "None" comment), BrTag [], BrTag []
, Text "Submit a new comment:", BrTag [], BrTag []]
?>> editTask "OK" textBox <<@ Submit
=>> \(HtmlTextarea _ comment) -> readMyMarksDB uniqueId
=>> \(mark,_) ->
writeMarksDB {userName = name, loginId = uniqueId, mark = mark, comment = comment}
#>> [ Text "Your comment:", BrTag [], BrTag []
, Text comment, BrTag [], BrTag []
, Text "has been stored!",BrTag [],BrTag []]
?>> OK
where
textBox :: HtmlTextarea
textBox = createDefault
Confirm name = buttonTask name (return_V Void)
OK = Confirm "OK"
STable atts table = TableTag atts (mktable table)
where
mktable table = [TrTag [] (mkrow rows) \\ rows <- table]
mkrow rows = [TdTag [ValignAttr "top"] [row] \\ row <- rows ]
// database specialized
marksId :: DBid [Mark]
marksId = mkDBid "marks" TxtFile
readMarksDB :: Task [Mark]
readMarksDB = readDB marksId
readMyMarksDB :: Int -> Task (Int,String)
readMyMarksDB id
= readMarksDB
=>> \marks -> return_V (case (filter (\mark -> mark.loginId == id) marks) of
[] -> (-1,"")
[mark:_] -> (mark.mark,mark.comment)
)
writeMarksDB :: Mark -> Task [Mark]
writeMarksDB acc
= readMarksDB
=>> \accs -> writeDB marksId [acc:[oacc \\ oacc <- accs | oacc.loginId <> acc.loginId]]
This diff is collapsed.
module newsGroups
// In this example newsgroups are created and maintained
// User 0 is the manager of the newsgroup who can create new newgroups
// All other users can subscribe to such a newsgroup, commit a message or read news
// (c) mjp 2007
import StdEnv, StdiTasks, iDataTrivial, iDataFormlib, iDataWidgets
derive gForm []
derive gUpd []
:: NewsGroups :== [GroupName] // list of newsgroup names
:: GroupName :== String // Name of the newsgroup
:: NewsGroup :== [News] // News stored in a news group
:: News :== (Subscriber,Name,Message) // id, name, and message of the publisher
:: Subscriber :== Int // the id of the publisher
:: Name :== String // the login name of the publisher
:: Message :== String // the message
:: Subscriptions:== [Subscription] // newsgroup subscriptions of user
:: Subscription :== (GroupName,Index) // last message read in corresponding group
:: Index :== Int // 0 <= index < length newsgroup
nmessage = 5
Start world = startTaskEngine (doWork 0 "Rinus") world
doWork 0 acc = newsManager 0 acc // for the root
doWork i acc = newsReader i acc // all others
newsManager i name
= spawnWorkflow i True ("subscribe",newsReader i name)
#>> manageGroups
where
manageGroups
= foreverTask
( chooseTask [Text "news group management:",BrTag [],BrTag []]
[ ("add new group", addNewsGroup -||- editTask "Cancel" Void)
, ("show groups", showGroups)
]
)
addNewsGroup
= [Text "Define name of new news group:",BrTag [],BrTag []]
?>> editTask "Define" ""
=>> \newName -> readNewsGroups
=>> \oldNames -> writeNewsGroups (removeDup (sort [newName:oldNames]))
#>> return_V Void
showGroups
= readNewsGroups
=>> showList
where
showList [] = [Text "No newsgroups in catalogue yet:", BrTag [],BrTag []] ?>> OK
showList list = PDMenu list #>> return_V Void
newsReader unid name
= foreverTask ( chooseTask [Text "subscribe to a news group from the cataloque:",BrTag [],BrTag []]
[("show groups", subscribeNewsGroup unid name -||- editTask "Cancel" Void)]
)
where
subscribeNewsGroup :: Subscriber String -> Task Void
subscribeNewsGroup me name
= readNewsGroups
=>> subscribe
where
subscribe []
= [Text "No newsgroups in catalogue yet:", BrTag [],BrTag []] ?>> OK
subscribe groups
= [Text "Choose a group:", BrTag [],BrTag []] ?>> PDMenu groups
=>> \(_,group) -> addSubscription me (group,0)
#>> spawnWorkflow me True (group,readNews me group)
#>> [Text "You have subscribed to news group ", BTag [] [Text group],BrTag [],BrTag []]
?>> OK
readNews me group = [Text "You are looking at news group ", BTag [] [Text group], BrTag [], BrTag []]
?>> foreverTask
( readIndex me group
=>> \index -> readNewsGroup group
=>> \news -> showNews index (news%(index,index+nmessage-1)) (length news)
?>> chooseTask []
[("<<", readNextNewsItems me (group,index) (~nmessage) (length news))
,("update", return_V Void)
,(">>", readNextNewsItems me (group,index) nmessage (length news))
,("commitNews", commitItem group me)
,("unsubscribe",deleteMe)
]
)
readNextNewsItems :: Subscriber Subscription Int Int -> Task Void
readNextNewsItems me (group,index) offset length
# nix = index + offset
# nix = if (nix < 0) 0 (if (length <= nix) index nix)
= addSubscription me (group,nix) #>> return_V Void
commitItem :: GroupName Subscriber -> Task Void
commitItem group me
= [Text "Type your message ..."]
?>> editTask "Commit" (HtmlTextarea 4 "") <<@ Submit
=>> \(HtmlTextarea _ val) -> readNewsGroup group
=>> \news -> writeNewsGroup group (news ++ [(unid,name,val)])
#>> [Text "Message commited to news group ",BTag [] [Text group], BrTag [],BrTag []]
?>> OK
OK :: Task Void
OK = editTask "OK" Void
PDMenu list
= []
?>> editTask "OK" (HtmlSelect [(e,e) \\ e <- list] (toString 0))
=>> \(HtmlSelect _ value)
-> return_V (toInt value, value)
// displaying news groups
showNews ix news nrItems = [STable [BorderAttr (toString 1), BgcolorAttr "Blue"]
[ [BTag [] [Text "Message nr:"], BTag [] [Text "By:"], BTag [] [Text "Contents:"]]
: [ [Text (showIndex nr),Text name,Text (toString info)]
\\ nr <- [ix..] & (who,name,info) <- news
]
]
]
where
showIndex i = ((i+1) +++> " of ") <+++ nrItems
STable atts table = TableTag atts (mktable table)
where
mktable table = [TrTag [] (mkrow rows) \\ rows <- table]
mkrow rows = [TdTag [ValignAttr "top"] [row] \\ row <- rows ]
// reading and writing of storages
newsGroupsId :: (DBid NewsGroups)
newsGroupsId = mkDBid "newsGroups" TxtFile
readerId :: Int -> (DBid Subscriptions)
readerId i = mkDBid ("reader" <+++ i) TxtFile
groupNameId :: String -> (DBid NewsGroup)
groupNameId name = mkDBid ("NewsGroup-" +++ name) TxtFile
readNewsGroups :: Task NewsGroups
readNewsGroups = readDB newsGroupsId
writeNewsGroups :: NewsGroups -> Task NewsGroups
writeNewsGroups newgroups = writeDB newsGroupsId newgroups
readSubscriptions :: Subscriber -> Task Subscriptions
readSubscriptions me = readDB (readerId me)
writeSubscriptions :: Subscriber Subscriptions -> Task Subscriptions
writeSubscriptions me subscriptions = writeDB (readerId me) subscriptions
addSubscription :: Subscriber Subscription -> Task Subscriptions
addSubscription me (groupname,index)
# index = if (index < 0) 0 index
= readSubscriptions me
=>> \subscriptions -> writeSubscriptions me [(groupname,index):[(group,index) \\ (group,index) <- subscriptions | group <> groupname]]
readIndex :: Subscriber GroupName -> Task Index
readIndex me groupname
= readSubscriptions me
=>> \subscriptions -> return_V (hds [index \\ (group,index) <- subscriptions | group == groupname])
where
hds [x:xs] = x
hds [] = 0
readNewsGroup :: GroupName -> Task NewsGroup
readNewsGroup groupname = readDB (groupNameId groupname)
writeNewsGroup :: GroupName NewsGroup -> Task NewsGroup
writeNewsGroup groupname news = writeDB (groupNameId groupname) news
This diff is collapsed.
module travel
import StdEnv, StdiTasks, iDataTrivial
// (c) 2007 MJP
// Test for multiple choice
// One can choose to book a flight, hotel and / or a car
// One by one the chosen bookings will be handled
// The bill is made up in the end
derive gForm []
derive gUpd []
Start world = startTaskEngine (foreverTask travel) world
travel :: (Task Void)
travel
= [Text "Book your journey:",BrTag [],BrTag []]
?>> seqTasks [ ( "Step 1: Make Bookings:"
, mchoiceTasks [Text "Choose Booking options:"]
[ ("Book Flight",BookFlight)
, ("Book Hotel", BookHotel)
, ("Book Car", BookCar)
]
)
, ( "Step 2: Confirm Bookings:"
, buttonTask "Confirm" (return_V [])
)
]
-||-
buttonTask "Cancel" (return_V [])
=>> \booking -> [Text "Handling bookings:",BrTag [],BrTag []]
?>> handleBookings booking
where
handleBookings booking
| isNil booking = editTask "Cancelled" Void
| otherwise = editTask "Pay" (Dsp (calcCosts booking))
#>> editTask "Paid" Void
where
calcCosts booked = sum [cost \\ (_,_,_,cost) <- hd booked]
isNil [] = True
isNil _ = False
BookFlight = editTask "BookFlight" (Dsp "Flight Number","",Dsp "Costs",0) <<@ Submit
BookHotel = editTask "BookHotel" (Dsp "Hotel Name","",Dsp "Costs",0) <<@ Submit
BookCar = editTask "BookCar" (Dsp "Car Brand","",Dsp "Costs",0) <<@ Submit
Dsp = DisplayMode
This diff is collapsed.
module date
import StdEnv, StdiTasks, iDataTrivial
// (c) MJP 2007
// findDate will settle a date and time between two persons that want to meet
// first a person is chosen by the person taken the initiative, person 0
// then a date is settled by the two persons by repeatedly asking each other for a convenient date
// if such a date is found both have to confirm the date and the task is finished
npersons = 5
Start world = startTaskEngine (foreverTask findDate) world
findDate :: Task (HtmlDate,HtmlTime)
findDate
= [Text "Choose person you want to date:",BrTag []]
?>> editTask "Set" (HtmlSelect [(toString i,toString i) \\ i <- [1..npersons - 1]] (toString 1))
=>> \(HtmlSelect _ whom) -> let whom = toInt whom
in
[Text "Determining date:",BrTag [],BrTag []]
?>> findDate` whom (HtmlDate 1 1 2007,HtmlTime 9 0 0)
=>> \datetime -> []
?>> confirm 0 whom datetime -&&- confirm whom 0 datetime
#>> return_V datetime
where
findDate` :: Int (HtmlDate,HtmlTime) -> Task (HtmlDate,HtmlTime)
findDate` whom daytime
= proposeDateTime daytime
=>> \daytime -> whom @: ("Meeting Request",determineDateTime daytime)
=>> \(ok,daytime) -> if ok
(return_V daytime)
( isOkDateTime daytime
=>> \ok -> if ok
(return_V daytime)
(newTask "findDate`" (findDate` whom daytime))
)
where
proposeDateTime :: (HtmlDate,HtmlTime) -> Task (HtmlDate,HtmlTime)
proposeDateTime (date,time)
= [Text "Propose a new date and time for meeting:",BrTag [],BrTag []]
?>> editTask "Set" input
=>> \(_,date,_,time) -> return_V (date,time)
where
input = (toString (Text "date: "), date, toString (Text "time: "), time)
determineDateTime :: (HtmlDate,HtmlTime) -> Task (Bool,(HtmlDate,HtmlTime))
determineDateTime daytime
= isOkDateTime daytime
=>> \ok -> if ok
(return_V (ok,daytime))
( proposeDateTime daytime
=>> \daytime -> return_V (ok,daytime)
)
isOkDateTime :: (HtmlDate,HtmlTime) -> Task Bool
isOkDateTime (date,time)
= chooseTask [Text ("Can we meet on the " <+++ date <+++ " at " <+++ time <+++ "?"),BrTag []]
[ ("Accept",return_V True)
, ("Sorry", return_V False)
]
confirm :: Int Int (HtmlDate,HtmlTime) -> Task Void
confirm me you (date,time)
= me @:: [Text ("User " <+++ me <+++ " and " <+++ you <+++ " have a meeting on " <+++ date <+++ " at " <+++ time),BrTag [],BrTag []]
?>> editTask "OK" Void
This diff is collapsed.
module deadline
import StdEnv, StdiTasks, iDataTrivial
derive gForm []
derive gUpd []
// (c) MJP 2007
// One can select a user to whom a task is delegated
// This user will get a certain amount of time to finish the task
// If the task is not finished on time, the task will be shipped back to the original user who has to do it instead
// It is also possible that the user becomes impatient and he can cancel the delegated task even though the deadline is not reached
npersons = 6
Start world = startTaskEngine (foreverTask (deadline mytask)) world
mytask = editTask "OK" 0 <| (\n -> if (n <= 42) (False,[Text ("Error " <+++ n <+++ " should be larger than 42")]) (True,[]))
deadline :: (Task a) -> Task a | iData a
deadline task
= [Text "Choose person you want to delegate work to:",BrTag [],BrTag []]
?>> editTask "Set" (HtmlSelect (map (\i -> (toString i,toString i)) [1..npersons - 1]) (toString 1))
=>> \(HtmlSelect _ whom) -> [Text "How long do you want to wait?",BrTag [],BrTag []]
?>> editTask "SetTime" (HtmlTime 0 0 0)
=>> \time -> [Text "Cancel delegated work if you are getting impatient:",BrTag [],BrTag []]
?>> (delegateTask (toInt whom) time task
-||-
buttonTask "Cancel" (return_V Nothing))
=>> CheckDone
where
CheckDone (Just value)