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 = { 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 :: UserName , location :: Location , capacity :: Int } ::Opinion = Opinion (UserName,String) Note //Static population allproviders = [{name="Ambulance Post 0",id="ambupost0",location={street="Teststreet",place="Testville",coordinates=Just{lat=1.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 1",id="ambupost1",location={street="Teststreet",place="Testville",coordinates=Just{lat=2.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 2",id="ambupost2",location={street="Teststreet",place="Testville",coordinates=Just{lat=3.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 3",id="ambupost3",location={street="Teststreet",place="Testville",coordinates=Just{lat=4.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 4",id="ambupost4",location={street="Teststreet",place="Testville",coordinates=Just{lat=5.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 5",id="ambupost5",location={street="Teststreet",place="Testville",coordinates=Just{lat=6.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 6",id="ambupost6",location={street="Teststreet",place="Testville",coordinates=Just{lat=7.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 7",id="ambupost7",location={street="Teststreet",place="Testville",coordinates=Just{lat=8.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 8",id="ambupost8",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=2.0}},capacity=2} ,{name="Ambulance Post 9",id="ambupost9",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=3.0}},capacity=2} ] derive gPrint Incident, IncidentType, Location, Address, MapCoordinates, Provider, Opinion derive gParse Incident, IncidentType, Location, Address, MapCoordinates, Provider, Opinion derive gVisualize Incident, IncidentType, Location, Address, MapCoordinates, Provider, Opinion derive gUpdate 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 "Describe the incident" chooseResponse :: Incident -> Task [Task Void] chooseResponse incident = updateMultipleChoice "Choose response" options (suggestion 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 = "Send police" @>> showMessage "Please send police" sendMedics :: Incident -> Task Void sendMedics incident = "Send ambulances" @>> requestAmbulances incident.Incident.nrInjured incident.Incident.location sendFireBrigade :: Incident -> Task Void sendFireBrigade incident = "Send fire brigade" @>> showMessage "Please send fire brigade" dispatchAmbulances :: Task Void dispatchAmbulances = enterInformation "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 (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,UserName,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 = oldParallel "Resource_requests" check predf allf [(delegateTaskTimeOut uid "Resource Request" amount task time_out >>= \mba -> return (resource, mba)) \\ (resource,uid,amount) <- resources] delegateTaskTimeOut :: UserName 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 "Ambulances are on their way" /* = 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