Commit 6bcc1e65 authored by cvs2snv's avatar cvs2snv

This commit was manufactured by cvs2svn to create tag 'clean-2-1-1'.

parent 24e35d34
module Algebra
import StdEnv, StdHtml
Start world = doHtml MyPage2 world
// representation of a simple process algebra:
:: PA = (.+.) infixl 6 PA PA // equivalent of process algebra +
| (.>.) infixl 5 PA PA // equivalent of proces algebra "followed by"
| E String // atom, the string will be used as the label of the button
// some example expressions (they have to be finite)
//expr = E "a" .+. (E "b1" .>. E "b2") .>. E "c"
//expr = E "a" .+. (E "a" .>. E "b") .>. E "c"
expr = E "koffie" .+. E "thee" .+. E "chocmelk" .>. E "melk" .+. E "suiker" .>. E "klaar"
MyPage2 hst
# (exprf,hst) = mkEditForm "expr" Edit (E "Init") hst
# (donebut,hst) = ListFuncBut False "but" Edit [(LButton defpixel "Done!",\b -> not b)] hst
# (boolstore,hst) = mkStoreForm "boolstore" donebut.value False hst
# (buttons,hst) = if boolstore.value (calcprocess exprf.value hst) ([EmptyBody],hst)
= mkHtml "Process Algebra Experiment"
[ H1 [] "Process Algebra Experiment"
, Br, Br
, if boolstore.value (toHtml exprf.value) (toBody exprf)
, Br
, toBody donebut
, Br , Br
, BodyTag buttons
] hst
MyPage hst
# (buttons,hst) = calcprocess expr hst
= mkHtml "Process Algebra Experiment"
[ H1 [] "Process Algebra Experiment"
, Br, Br
, BodyTag buttons
, Br
] hst
// small utility stuf
mkHtml s tags hst = (Html (header s) (body tags),hst)
header s = Head [`Hd_Std [Std_Title s]] []
body tags = Body [] tags
// internal representation: a unique number is added to each possible next event that can occur
:: PAE = PAE String Int // possible event labeled with a unique number
| (.+) infixl 6 PAE PAE // process algebra +
| (.>) infixl 5 PAE PA // proces algebra "followed by"
derive gForm PAE, PA, []
derive gUpd PAE, PA, []
derive gPrint PAE, PA
derive gParse PAE, PA
// first the current set of buttons is read from store "butstore"
// this is used to re-create these "buttons"; funchosen is the function corresponding to the button pressed
// in "store" the process algebra expression is stored: the new expression is calculated depending on the button pressed and stored
// from the new expression the new set of buttons is calculated (nbutset); and stored in "butstore" for the next time
// this is used to calculate the new "buttons" to display
// the next time we start from the beginning
calcprocess :: PA *HSt -> *([BodyTag],*HSt)
calcprocess expr hst
# (butset,hst) = mkStoreForm "butstore" id initbuttonset hst
# (funchosen,hst) = ListFuncBut False "buttons" Edit (calcbuttons butset.value) hst
# (nbutset,hst) = mkStoreForm "store" funchosen.value initstore hst
# (_,hst) = mkSetForm "butstore" Display (snd nbutset.value) hst
# (buttons,hst) = ListFuncBut True "buttons" Edit (calcbuttons (snd nbutset.value)) hst
= (buttons.body,hst)
where
initstore = calcnext expr
initbuttonset = snd initstore
// calculate buttons out of the set of next event that can occur
calcbuttons :: [PAE] -> [(Button, (PAE,[PAE]) -> (PAE,[PAE]))]
calcbuttons paes = reverse [(LButton size label,\pae -> nextstate number pae) \\ (PAE label number) <- paes]
where
size = defpixel
nextstate :: Int (PAE,[PAE]) -> (PAE,[PAE])
nextstate eventnr (pae,_)
# (b,more) = calcnextevent pae eventnr
| b = case more of
Just npae = npae
Nothing = done
= done
done = (PAE "Done!" 0,[])
calcnext :: PA -> (PAE,[PAE]) // numbers all possible events with a unique number (>= 0)
// returns these events in a list to make buttons generating easier
calcnext pa
# (pai,list,_) = (next` pa [] 0)
= (pai,list)
where
next` :: PA [PAE]Int -> (PAE,[PAE],Int)
next` (E s) list n = (ne, [ne:list],n+1) where ne = PAE s n
next` (left .+. right) list n
# (left,list,n) = next` left list n
# (right,list,n) = next` right list n
= (left .+ right,list,n)
next` (left .>. right) list n
# (left,list,n) = next` left list n
= (left .> right,list,n)
calcnextevent :: PAE Int -> (Bool,Maybe (PAE,[PAE])) // calculates new expression given event i
calcnextevent pai i = search pai i
where
search (PAE s j) i = (i == j,Nothing) // event found if i == j, no more to do here
search (left .> right) i
# (b,moreleft) = search left i
| b = case moreleft of
Nothing -> (b, Just (calcnext right)) // continue with right
Just (leftmore,set) -> (b, Just (leftmore .> right,set)) // not quite finished left
= (b,Nothing) // event not found here
search (left .+ right) i
# (b,moreleft) = search left i
| b = (b,moreleft)
= search right i
This diff is collapsed.
definition module CDdatabaseHandler
:: CD_Database
= { item :: Item
, cd :: CD
}
:: Item
= { itemnr :: !Int
, instock :: !Int
, prize :: !Int
}
:: CD
= { group :: !Group
, album :: !Album
, year :: !Year
, totaltime :: !Duration
, tracks :: ![Track]
}
:: Track
= { nr :: !Int
, title :: !String
, playtime :: !Duration
}
:: Duration
= { minutes :: !Int
, seconds :: !Int
}
:: Group :== String
:: Album :== String
:: Year :== Int
readCD :: *World -> (*World,[CD])
readCD_Database :: *World -> (*World,[CD_Database])
:: SearchOption = AnyAlbum | AnyArtist | AnySong
searchDatabase :: SearchOption String [CD_Database] -> (Bool,[CD_Database])
instance toString Duration
showPrize :: Int -> String
implementation module CDdatabaseHandler
import StdEnv, StdMaybe
readCD_Database :: *World -> (*World,[CD_Database])
readCD_Database world
# (world,cds) = readCD world
= (world, [ { item = {itemnr = i, instock = 1, prize = max 500 (2000 - (100 * (2005 - cd.year)))}
, cd = cd
}
\\ cd <- cds & i <- [0..]
])
where
max i j = if (i>j) i j
readCD :: *World -> (*World,[CD])
readCD world
= case readFile "Nummers.dbs" world of // read Nummers.dbs
(Nothing,world) = abort "Could not read 'Nummers.dbs'.\n" // failure: report
(Just inlines,world) = (world, convertDB inlines) // read all cds
/*********************************************************************
Basic operations on Duration:
*********************************************************************/
instance fromString Duration where
fromString duration_text
= case [c \\ c<-:duration_text] of
[m1,m2,':',s1,s2,nl] = {minutes=digit m1*10+digit m2, seconds=digit s1*10+digit s2}
[ m2,':',s1,s2,nl] = {minutes= digit m2, seconds=digit s1*10+digit s2}
otherwise = abort ("fromString: argument "+++duration_text+++" has wrong format.\n")
where
digit c = toInt c - toInt '0'
instance toString Duration where
toString {minutes,seconds}
= minutes_txt +++ ":" +++ seconds_txt
where
minutes_txt = toString minutes
seconds_txt = if (seconds<=9) ("0"+++toString seconds) (toString seconds)
class toDuration a :: !a -> Duration
instance toDuration String where
toDuration x = fromString x
instance zero Duration where
zero = {minutes=0,seconds=0}
instance + Duration where
(+) {minutes=m1,seconds=s1} {minutes=m2,seconds=s2}
= {minutes=m1+m2+s/60, seconds=s rem 60}
where
s = s1+s2
instance < Duration where
(<) {minutes=m1,seconds=s1} {minutes=m2,seconds=s2}
= m1<m2 || m1==m2 && s1<s2
instance == Duration where
(==) {minutes=m1,seconds=s1} {minutes=m2,seconds=s2}
= m1==m2 && s1==s2
/***********************************************************
Convert list of strings to list of CDs
***********************************************************/
convertDB :: [String] -> [CD]
convertDB lines
= cds
where
allRecords = map (toDBRecord o tl) (groups 7 (drop 7 lines))
allKeys = removeDup [(group,cd,year) \\ (group,cd,year,_,_,_) <- allRecords]
cdRecords = [filter (\(g,c,y,_,_,_) = g==group && c==cd && y==year) allRecords \\ (group,cd,year) <- allKeys]
cds = map toCD cdRecords
:: DBRecord :== (String,String,String,String,String,String)
toDBRecord :: [String] -> DBRecord
toDBRecord [r1,r2,r3,r4,r5,r6] = (noControl r1,noControl r2,noControl r3,noControl r4,noControl r5,noControl r6)
toCD :: [DBRecord] -> CD
toCD cdrs=:[(group,album,year,_,_,_):_]
= { group = group
, album = album
, year = fromString (initstr year)
, totaltime = sum (map (\(_,_,_,_,_,t) -> fromString t) cdrs)
, tracks = sortBy (\tr1 tr2 = tr1.nr < tr2.nr) [{nr=fromString (initstr nr),title=noControl title,playtime=fromString t} \\ cdr=:(_,_,_,nr,title,t)<-cdrs]
}
// groups n [a11,..,a1n,a21,..,a2n,..,am1,..,amn] = [[a11,..,a1n],[a21,..,a2n],..,[am1,..,amn]]
groups :: Int [a] -> [[a]]
groups n as
| length first_n < n
= []
| otherwise
= [first_n : groups n rest]
where
(first_n,rest) = splitAt n as
// Lezen van bestand naar lijst van newline-terminated strings:
readFile :: String !*env -> (!Maybe [String],!*env) | FileSystem env
readFile fileName env
# (ok,file,env) = sfopen fileName FReadText env
| not ok = (Nothing,env)
| otherwise = (Just (readLines file),env)
where
readLines :: File -> [String]
readLines file
| sfend file = []
| otherwise = let (line,file1) = sfreadline file
in [line : readLines file1]
writeFile :: String [String] !*env -> *env | FileSystem env
writeFile fileName lines env
# (ok,file,env) = fopen fileName FWriteText env
| not ok = abort "Could not open file.\n"
# file = foldl (flip fwrites) file lines
# (ok,env) = fclose file env
| not ok = abort "Could not close file.\n"
| otherwise = env
writeToStdOut :: [String] !*env -> *env | FileSystem env
writeToStdOut lines env
# (io,env) = stdio env
# io = foldl (flip fwrites) io lines
# (_,env) = fclose io env
= env
// small utility stuf
initstr :: !String -> String
initstr "" = ""
initstr txt = txt%(0,size txt-2)
instance fromString Int where fromString txt = toInt txt
concat strs = foldr (+++) "" strs
noControl string = {if (isControl s) ' ' s \\ s <-: string }
showPrize :: Int -> String
showPrize val = "Euro " +++ sval%(0,s-3) +++ "." +++ sval%(s-2,s-1)
where
sval = toString val
s = size sval
searchDatabase :: SearchOption String [CD_Database] -> (Bool,[CD_Database])
searchDatabase _ "" database = (True,database)
searchDatabase AnyAlbum string database
= check database [items \\ items <- database | isSubstring string items.cd.album]
searchDatabase AnyArtist string database
= check database [items \\ items <- database | isSubstring string items.cd.group]
searchDatabase AnySong string database
= check database [items \\ items <- database | or [isSubstring string title \\ {title} <- items.cd.tracks]]
searchDatabase _ string database = (False,[])
check database [] = (False,[])
check database ndatabase = (True,ndatabase)
isSubstring :: String String -> Bool
isSubstring searchstring item = compare` [toLower c1 \\ c1 <-: searchstring | isAlphanum c1] [toLower c2 \\ c2 <-: item | isAlphanum c2]
where
compare` [] _ = True
compare` ss is
| length ss > length is = False
compare` search=:[s:ss] [is:iss]
| s == is = if (ss == iss%(0,length ss - 1)) True (compare` search iss)
| otherwise = compare` search iss
comapre` _ _ = False
This diff is collapsed.
module coffeemachine
import StdEnv
import StdHtml
derive gForm MachineState, Output, Product
derive gUpd MachineState, Output, Product
derive gPrint MachineState, Output, Product
derive gParse MachineState, Output, Product
Start world = doHtml coffeemachine world
coffeemachine hst
# (input ,hst) = ListFuncBut False "cb" Edit allbuttons hst
# (options ,hst) = ListFuncCheckBox False "op" Edit (optionbuttons False False) hst
# (optionfun,optionbool) = options.value
# (machine ,hst) = mkStoreForm "hidden" (optionfun o input.value) initmachine hst
# (checkboxf,hst) = ListFuncCheckBox True "op" Edit (optionbuttons machine.value.milk machine.value.sugar) hst
= mkHtml "Coffee Machine"
[ H1 [] "Fancy Coffee Machine ..."
, Br
, [ mkSTable [[bTxt "Content:", bTxt "Value:",bTxt "Input:"]]
, toHtml ("money ",machine.value.money) <.=.> mkRowF (input.body%MoneyButtons)
, toHtml ("beans ",machine.value.beans) <.=.> input.body!!BeansButton
, toHtml ("trash ",machine.value.trash) <.=.> input.body!!TrashButton
, Br
, bTxt "Options: "
, Br
, checkboxf.body!!MilkOption <.=.> bTxt "Milk"
, checkboxf.body!!SugarOption <.=.> bTxt "Sugar"
, Br
, mkSTable [[bTxt "Product:", bTxt "Prize:"]]
, mkColF (input.body%ProductButtons) <.=.> mkColF (map toHtml prizes)
, Br
, bTxt "Message: ", bTxt (print machine.value.out optionbool)
] <=> [displayMachineImage machine.value.out]
] hst
where
allbuttons =
[ (butp "CoffeeBeans.jpg", \m -> CoffeeMachine (AddBeans, m))
, (but "Empty_Trash", \m -> CoffeeMachine (EmptyTrash, m))
, (but "Coffee", \m -> CoffeeMachine (Ask Coffee, m))
, (but "Capuccino", \m -> CoffeeMachine (Ask Capuccino, m))
, (but "Espresso", \m -> CoffeeMachine (Ask Espresso, m))
]
++
[moneybuttons n \\ n <- [200, 100, 50, 10, 5]]
where
moneybuttons n = (butp (toString n +++ ".gif"), \m -> CoffeeMachine (InsertCoin n, m))
but s = LButton defpixel s
butp s = PButton (defpixel/2,defpixel/2) ("images/" +++ s)
optionbuttons milk sugar=
[ (check milk "Milk", \b _ m -> CoffeeMachine (AskMilk b, m))
, (check sugar "Sugar", \b _ m -> CoffeeMachine (AskSugar b, m))
]
where
check True = CBChecked
check False = CBNotChecked
prizes = [cost Coffee,cost Capuccino, cost Espresso]
displayMachineImage (Prod x) = machineImage 4
displayMachineImage (Message s) = machineImage 0
machineImage i = Img [Img_Src ("images/coffeemachine0" +++ toString i +++ ".jpg"), Img_Width (RelLength 560) ,Img_Height (RelLength 445)]
mkHtml s tags hst = (Html (header s) (body tags),hst)
header s = Head [`Hd_Std [Std_Title s]] []
body tags = Body [] tags
bTxt = B []
print output [milkoption,sugaroption]
= printoutput output
where
printoutput (Message s) = s
printoutput (Prod Coffee) = "Enjoy your coffee" +++ printoptions milkoption sugaroption
printoutput (Prod Capuccino) = "Enjoy your capuccino" +++ printoptions milkoption sugaroption
printoutput (Prod Espresso) = "Enjoy your espresso" +++ printoptions milkoption sugaroption
printoptions milk sugar
| milk && sugar = " with milk and sugar"
| milk = " with milk"
| sugar = " with sugar"
printoptions _ _ = ""
BeansButton = 0
TrashButton = 1
ProductButtons = (2,4)
MoneyButtons = (5,9)
MilkOption = 0
SugarOption = 1
// Coffee machine with standard options ...
:: Client // Client actions:
= InsertCoin Int // insert a coin of int cents
| Ask Product // ask for product
| AddBeans // add beans in machine
| EmptyTrash // empty bean trash of machine
| AskMilk Bool // milk yes or no
| AskSugar Bool // sugar yes or no
| Idle // does nothing
:: MachineState // CoffeeMachine:
= { money :: Int // nr of coins (maxCoins)
, beans :: Int // amount of beans (maxBeans)
, trash :: Int // amount of bean-trash (maxTrash)
, milk :: Bool // milk wanted
, sugar :: Bool // sugar wanted
, out :: Output // output of machine
}
:: Product = Coffee | Capuccino | Espresso
:: Msg :== String // Errors or customer-friendly information
:: Output = Message Msg | Prod Product
initmachine = { money = 0
, beans = 6
, trash = 0
, milk = False
, sugar = False
, out = Message "Welcome."
}
// Finite State Handling of this Coffee Machine
CoffeeMachine :: (Client,MachineState) -> MachineState
CoffeeMachine (InsertCoin n, m=:{money})
| money >= maxCoins = { m & out = Message "Coin not accepted." }
| otherwise = { m & money = money+n, out = Message "Thank you." }
CoffeeMachine (EmptyTrash, m) = { m & trash = 0, out = Message "Trash emptied." }
CoffeeMachine (AddBeans, m=:{beans})
| beans > maxBeans-beanBag = { m & out = Message "Too many beans." }
| otherwise = { m & beans = beans+beanBag, out = Message "Beans refilled." }
CoffeeMachine (AskMilk b, m) = { m & milk = b, out = Message (if b "Milk will be added" "No Milk")}
CoffeeMachine (AskSugar b, m) = { m & sugar = b, out = Message (if b "Sugar will be added" "No Sugar")}
CoffeeMachine (Ask p,m=:{money,beans,trash})
| beans < beancost p = { m & out = Message "Not enough Beans." }
| money < cost p = { m & out = Message "Not enough money inserted." }
| trash + ptrash p > maxTrash = { m & out = Message "Trash full." }
| otherwise = { m & out = Prod p
, beans = beans - beancost p
, money = money - cost p
, trash = trash + ptrash p
, milk = False
, sugar = False
}
CoffeeMachine (_,m) = m
maxCoins :== 1000 // max. number of money in machine
maxBeans :== 20 // max. amount of coffeebeans in machine
maxTrash :== 5 // max. amount of coffeetrash in machine
beanBag :== 10 // unit of bean refill
// The number of coins that a product costs
cost :: Product -> Int
cost Coffee = 100
cost Capuccino = 175
cost Espresso = 150
// The number of beans that a product costs
beancost :: Product -> Int
beancost Coffee = 2
beancost Capuccino = 3
beancost Espresso = 3
// Amount of trash generated by product
ptrash :: Product -> Int
ptrash _ = 1
<html>
<?php
// collect posted values
$args = "#";
foreach ($_POST as $key => $value)
{ $args = $args . $key . " = " . $value . " ; " ; }
// collect arguments passed to this script
$arguments = $_SERVER['argv'];
$phpargs = "#";
foreach ($arguments as $key => $value)
{ $phpargs = $phpargs . $key . " == " . $value . " : " ; }
echo exec("coffeemachine.exe -con $phpargs $args");
?>
</html>
\ No newline at end of file
This diff is collapsed.
<html>
<?php
// collect posted values
$args = "#";
foreach ($_POST as $key => $value)
{ $args = $args . $key . " = " . $value . " ; " ; }
// collect arguments passed to this script
$arguments = $_SERVER['argv'];
$phpargs = "#";
foreach ($arguments as $key => $value)
{ $phpargs = $phpargs . $key . " == " . $value . " : " ; }
echo exec("webshop.exe -con $phpargs $args");
?>
</html>
\ No newline at end of file
This diff is collapsed.
module Counter
import StdEnv
import StdHtml
Start world = doHtml MyPage world
MyPage hst
# (counterf,hst) = counterForm "counter" Edit 0 hst
= mkHtml "Counter Example"
[ H1 [] "Counter Example"
, Br
, toBody counterf
] hst
where
mkHtml s tags hst = (Html (header s) (body tags),hst)
header s = Head [`Hd_Std [Std_Title s]] []
body tags = Body [] tags
This diff is collapsed.
module GPCE2005
/** Examples that appear in the GPCE 2005 paper.
<