implementation module AmbulanceDispatch import iTasks import GenEq ambulanceDispatchExamples :: [Workflow] ambulanceDispatchExamples = flows where flows = [ workflow "Examples/Crisis response/Report incident" "Report an incident" reportIncident , workflow "Examples/Crisis response/Dispatch ambulances" "Dispatch ambulances to an incident" dispatchAmbulances ] //Crisis management data domain :: Incident = { type :: IncidentType , time :: Time , nrInjured :: Int , description :: String , location :: Address } :: IncidentType = Accident | Fire | Fight | Other String :: Location = { street :: String , place :: String , coordinates :: Maybe MapCoordinates } :: Address = { street :: String , place :: String } :: MapCoordinates = { lat :: Real , lon :: Real } ::Provider = { name :: String , id :: User , location :: Location , capacity :: Int } ::Opinion = Opinion User Note //Static population allproviders = [{name="Ambulance Post 0",id=NamedUser "ambupost0",location={street="Teststreet",place="Testville",coordinates=Just{lat=1.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 1",id=NamedUser "ambupost1",location={street="Teststreet",place="Testville",coordinates=Just{lat=2.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 2",id=NamedUser "ambupost2",location={street="Teststreet",place="Testville",coordinates=Just{lat=3.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 3",id=NamedUser "ambupost3",location={street="Teststreet",place="Testville",coordinates=Just{lat=4.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 4",id=NamedUser "ambupost4",location={street="Teststreet",place="Testville",coordinates=Just{lat=5.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 5",id=NamedUser "ambupost5",location={street="Teststreet",place="Testville",coordinates=Just{lat=6.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 6",id=NamedUser "ambupost6",location={street="Teststreet",place="Testville",coordinates=Just{lat=7.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 7",id=NamedUser "ambupost7",location={street="Teststreet",place="Testville",coordinates=Just{lat=8.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 8",id=NamedUser "ambupost8",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 9",id=NamedUser "ambupost9",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=3.0}},capacity=2} ] derive class iTask Incident, IncidentType, Location, Address, MapCoordinates, Provider, Opinion derive bimap (,), Maybe derive gEq IncidentType reportIncident :: Task [Void] reportIncident = enterIncident >>= chooseResponse >>= allTasks where enterIncident :: Task Incident enterIncident = enterInformation "Incident report" "Describe the incident" chooseResponse :: Incident -> Task [Task Void] chooseResponse incident = updateMultipleChoice "Response" "Choose response" options (suggestion incident.Incident.type) where //Generate the list of possible tasks to choose from options = [f incident \\ f <- [sendPolice,sendMedics,sendFireBrigade]] //Compute the indexes in the options list that are initially selected suggestion Accident = [0,1] suggestion Fire = [0,2] suggestion Fight = [0] suggestion _ = [] sendPolice :: Incident -> Task Void sendPolice incident = showMessage "Send police" "Please send police" Void sendMedics :: Incident -> Task Void sendMedics incident = Subject "Send ambulances" @>> requestAmbulances incident.Incident.nrInjured incident.Incident.location sendFireBrigade :: Incident -> Task Void sendFireBrigade incident = showMessage "Send fire brigade" "Please send fire brigade" Void dispatchAmbulances :: Task Void dispatchAmbulances = enterInformation "Dispatch ambulances" "How many ambulances do you need at what location?" >>= \(nr,loc) -> requestAmbulances nr loc // 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 Address -> Task Void requestAmbulances amount address //| 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 "Request" (flatten [[Text (p.Provider.name +++ " is asked for " <+ p.capacity),BrTag []]\\p <- providers]) Void // 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,User,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 Closed "Resource requests" "Waiting for resources..." procfun finalfun [] tasks where tasks = [(delegateTaskTimeOut uid "Resource Request" amount task time_out >>= \mba -> return (resource, mba)) \\ (resource,uid,amount) <- resources] procfun (result,index) st # st = sortBy (\x y. snd x < snd y) [(result,index):st] | check (map fst st) = (st, Stop) = (st,Continue) finalfun st # results = map fst st | length st < length tasks = predf results | otherwise = allf results delegateTaskTimeOut :: User String a (a -> Task a) Time -> Task (Maybe a) | iTask a delegateTaskTimeOut who description value task time_out = timeOutTask (who @: (Subject 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 "Amount" ("I need " <+ amount <+ " ambulances, how much can you provide?") amount showAmbulances :: [(Provider, Maybe Int)] -> Task Void showAmbulances providers = showMessage "Summary" "Ambulances are on their way" Void //Utilities (<+) infixl :: !String !a -> String | toString a (<+) str x = str +++ toString x oneMinute :== {Time | hour = 0, min = 1, sec = 0} end :== return Void