Added Jan Martin's ambulance dispatch example to the standard set of examples....

Added Jan Martin's ambulance dispatch example to the standard set of examples. It needs some more polishing though

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@635 63da3aa8-80fd-4f01-9db8-e6ea747a3da2

AllExamples.icl

@@ -25,6 +25,9 @@ import Newsgroups
 import ChangeHandling
 import WebShop
 
+//Crisis response examples
+import AmbulanceDispatch
+
 //Administrative tasks
 import ProcessAdmin
 
@@ -48,5 +51,6 @@ where
 						, exceptionHandlingExample
 						, changeHandlingExample
 						, webShopExample
+						, ambulanceDispatchExamples
 						, processAdmin
 						]
\ No newline at end of file

Examples/Crisis response/AmbulanceDispatch.dcl

+definition module AmbulanceDispatch
+
+import iTasks
+
+ambulanceDispatchExamples :: [Workflow]
\ No newline at end of file

Examples/Crisis response/AmbulanceDispatch.icl

+implementation module AmbulanceDispatch
+
+import iTasks
+import GenEq
+import CommonDomain
+
+ambulanceDispatchExamples :: [Workflow]
+ambulanceDispatchExamples = flows
+where
+	flows =	[ workflow "Examples/Crisis response/Report incident" reportIncident
+			, workflow "Examples/Crisis response/Dispatch ambulances" dispatchAmbulances
+			]
+			
+//Crisis management data domain
+
+:: Incident =
+	{ location    :: Location
+	, type        :: IncidentType
+	, time        :: Time
+	, nrInjured   :: Int
+	, description :: String
+	}
+
+:: IncidentType = Accident | Fire | Fight | Other String
+	
+:: Location =
+	{ street		:: String
+	, place			:: String
+	, coordinates	:: Maybe MapCoordinates
+	}	
+	
+:: MapCoordinates =
+	{ lat			:: Real
+	, lon			:: Real
+	}
+	
+::Provider =
+	{ name			:: String
+	, id			:: UserId
+	, location		:: Location
+	, capacity		:: Int
+	}
+
+::Opinion = Opinion (UserId,String) Note
+
+//Static population
+
+allproviders  = [{name="Ambulance Post 0",id=30,location={street="Teststreet",place="Testville",coordinates=Just{lat=1.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 1",id=31,location={street="Teststreet",place="Testville",coordinates=Just{lat=2.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 2",id=32,location={street="Teststreet",place="Testville",coordinates=Just{lat=3.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 3",id=33,location={street="Teststreet",place="Testville",coordinates=Just{lat=4.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 4",id=34,location={street="Teststreet",place="Testville",coordinates=Just{lat=5.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 5",id=35,location={street="Teststreet",place="Testville",coordinates=Just{lat=6.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 6",id=36,location={street="Teststreet",place="Testville",coordinates=Just{lat=7.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 7",id=37,location={street="Teststreet",place="Testville",coordinates=Just{lat=8.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 8",id=38,location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=2.0}},capacity=2}
+				,{name="Ambulance Post 9",id=39,location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=3.0}},capacity=2}
+				]
+
+derive gPrint		Incident, IncidentType, Location, MapCoordinates, Provider, Opinion			
+derive gParse		Incident, IncidentType, Location, MapCoordinates, Provider, Opinion
+derive gVisualize 	Incident, IncidentType, Location, MapCoordinates, Provider, Opinion
+derive gUpdate		Incident, IncidentType, Location, MapCoordinates, Provider, Opinion
+
+
+
+derive gEq IncidentType
+
+
+
+// Crisis management procedure examples		
+reportIncident :: Task [Void]
+reportIncident
+	=				enterInformation "Please provide as many details about the incident as possible"
+	>>= \inc ->		enterMultipleChoice "Which actions must be taken?"
+						(map fst (filter snd 
+							[(requestAmbulances inc.Incident.nrInjured inc.Incident.location <<@ "Send ambulances", inc.Incident.nrInjured > 0)
+							,(requestFireBrigade <<@ "Request fire brigade", inc.Incident.type === Fire)
+							]))
+	>>= \tasks ->	allTasks tasks
+
+dispatchAmbulances :: Task Void
+dispatchAmbulances
+	=					enterInformation "How many ambulances do you need at what location?"
+	>>= \(nr,loc) ->	requestAmbulances nr loc
+
+requestFireBrigade :: Task Void
+requestFireBrigade = return Void
+
+// Request for amount ambulances from list of candidate providers
+// First, from the list enough providers are selected that can in principle provide the needed amount
+// They are asked in parallel
+// But in case they do not provide enough, more providers are asked
+// This is repeated until the requested amount can be fulfilled
+// Nore: we assume there are enough providers to supply all ambulances
+requestAmbulances :: Int Location -> Task Void
+requestAmbulances amount location	
+	| isJust location.coordinates	= requestAmbulances` amount (sortProviders location allproviders) >>= showAmbulances
+	| otherwise						= requestAmbulances` amount allproviders >>= showAmbulances
+
+requestAmbulances` amount providers
+	# (pvs,remainder) = 	determineNeededAmounts amount providers [] 
+	= 						displayRequest pvs
+							||- ambulanceRequest amount pvs oneMinute ambulanceTask   		
+		>>= \(left,list) ->	if (left == 0) (return list) 						// enough ambulances
+		                                   (requestAmbulances` left remainder)	// ask for more
+
+// Sort ambulance posts on distance from place of accident
+sortProviders :: Location [Provider] -> [Provider]
+sortProviders location providers
+		= sortBy (\p1 p2 -> distProv location p1.Provider.location < distProv location p2.Provider.location) providers 
+where
+	distProv l1 l2 = sqrt ((latDist l1 l2)^2.0 + (lonDist l1 l2)^2.0)
+	latDist l1 l2 = (fromJust l1.Location.coordinates).lat - (fromJust l2.Location.coordinates).lat
+	lonDist l1 l2 = (fromJust l1.Location.coordinates).lon - (fromJust l2.Location.coordinates).lon
+
+displayRequest :: [Provider] -> Task Void
+displayRequest providers = showStickyMessage (flatten [[Text (p.Provider.name +++ " is asked for " <+ p.capacity),BrTag []]\\p <- providers])
+
+// Calculates for a needed amount (left,providers,remainder)
+// left: is the amount that could not fulfilled (0 in case all can be supplied)
+// providers: list of providers and the amount that they should deliver
+// remainder: providers that remain (with there amounts)
+determineNeededAmounts :: Int [Provider] [Provider] -> ([Provider],[Provider])
+determineNeededAmounts tot [] used = (used,[])
+determineNeededAmounts tot [sup=:{name,id,location,capacity}:providers] used
+	| capacity <  tot = determineNeededAmounts (tot - capacity) providers  [sup : used]
+	| capacity >= tot = ([{sup & capacity = tot}:used],providers)
+
+			
+// Make a request for amount ambulances to providers
+// return (left,[(provider,actualamount)])
+// left: the amount that could not be provided
+// (provider,actualAmount): the actual amount that provider provides
+ambulanceRequest :: Int [Provider] Time (Int -> Task Int) -> Task (Int,[(Provider,Maybe Int)]) 
+ambulanceRequest needed providers time_out task 
+	= resourceRequestTimeOut 
+				    [(prov, prov.Provider.id, prov.capacity) \\ prov <- providers] 
+                    time_out 
+                    (enough needed) 
+                    preCombine
+                    allCombine
+                    task             
+where
+	numAmbulances (_,Nothing)	= 0
+	numAmbulances (_,Just x)	= x
+	
+	enough needed as			= sum (map numAmbulances as) >= needed
+	
+	preCombine as				= (0,as)
+	allCombine as				= (needed - sum (map numAmbulances as),as)
+	
+resourceRequestTimeOut :: [(b,UserId,a)] Time ([(b,Maybe a)] -> Bool) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) (a -> Task a) -> 
+                             Task (a,[(b,Maybe a)]) | iTask a & iTask b
+resourceRequestTimeOut resources time_out check predf allf task
+	= parallel "Resource_requests" check predf allf 
+             [(delegateTaskTimeOut uid "Resource Request" amount task time_out >>= \mba -> return (resource, mba)) 
+             \\ (resource,uid,amount) <- resources]
+
+delegateTaskTimeOut :: UserId String a (a -> Task a) Time -> Task (Maybe a) | iTask a
+delegateTaskTimeOut who description value task time_out 
+	= timeOutTask (who @: (description, task value)) time_out 
+   			  
+timeOutTask :: (Task a) Time -> Task (Maybe a) | iTask a
+timeOutTask task time
+	= (task >>= \a -> return (Just a)) -||- (waitForTimer time >>| return Nothing)
+
+ambulanceTask :: Int -> Task Int
+ambulanceTask amount
+	= updateInformation ("I need " <+ amount <+ " ambulances, how much can you provide?") amount
+
+showAmbulances :: [(Provider, Maybe Int)] -> Task Void
+showAmbulances providers
+	= showMessage (tableView [[p.Provider.name +++ ": ", case i of Nothing = "Timed out" ; (Just n) = ("Can send " <+ n <+ " ambulances")] \\ (p,i) <- providers])
+where
+	tableView rows = [TableTag [] [TrTag [] [TdTag [] [Text cell] \\cell <- row] \\row <- rows]]	
+
+//Utilities
+(<+) infixl :: !String !a -> String | toString a
+(<+) str x = str +++ toString x
+	
+
+oneMinute	:== {Time | hour = 0, min = 1, sec = 0}
+end			:== return Void
\ No newline at end of file

Libraries/iTasks/Framework/Data/UserDB.icl

@@ -22,6 +22,18 @@ testUsers = [ {User | userId = 1, userName = "bas", displayName = "Bas", passwor
   			, {User | userId = 20, userName = "megastore", displayName = "Megastore", password = "", roles = ["supplier"]}
 			, {User | userId = 21, userName = "localshop", displayName = "Local shop", password = "", roles = ["supplier"]}
 			, {User | userId = 22, userName = "webshop", displayName = "Webshop.com", password = "", roles = ["supplier"]}   
+			
+			, {User | userId = 30, userName = "ambupost0", displayName = "Ambulance Post 0", password = "", roles = ["ambulances"]}
+			, {User | userId = 31, userName = "ambupost1", displayName = "Ambulance Post 1", password = "", roles = ["ambulances"]}
+			, {User | userId = 32, userName = "ambupost2", displayName = "Ambulance Post 2", password = "", roles = ["ambulances"]}   
+			, {User | userId = 33, userName = "ambupost3", displayName = "Ambulance Post 3", password = "", roles = ["ambulances"]}   
+			, {User | userId = 34, userName = "ambupost4", displayName = "Ambulance Post 4", password = "", roles = ["ambulances"]}   
+			, {User | userId = 35, userName = "ambupost5", displayName = "Ambulance Post 5", password = "", roles = ["ambulances"]}   
+			, {User | userId = 36, userName = "ambupost6", displayName = "Ambulance Post 6", password = "", roles = ["ambulances"]}   
+			, {User | userId = 37, userName = "ambupost7", displayName = "Ambulance Post 7", password = "", roles = ["ambulances"]}   
+			, {User | userId = 38, userName = "ambupost8", displayName = "Ambulance Post 8", password = "", roles = ["ambulances"]}   
+			, {User | userId = 39, userName = "ambupost9", displayName = "Ambulance Post 9", password = "", roles = ["ambulances"]}  
+			
 			]
 /*
 testUsers :: [User]