https://wiki.haskell.org/index.php?title=Shootout/Healthcare&feed=atom&action=history
Shootout/Healthcare - Revision history
2024-03-19T04:19:37Z
Revision history for this page on the wiki
MediaWiki 1.35.5
https://wiki.haskell.org/index.php?title=Shootout/Healthcare&diff=6715&oldid=prev
DonStewart: moved
2006-10-08T02:29:29Z
<p>moved</p>
<p><b>New page</b></p><div><br />
'''This is an old ALPHA benchmark they were considering last year. It did not progress to become part of suite of maintained benchmarks, and it is likely that it never will'''<br />
<br />
Bummer about that. I've found the Shootout entries a reasonably effective (though synthetic) way to help me learn about Haskell. Though coding a fractal in Haskell was pretty straightforward, I was having a rough time figuring out how to code this entry in Haskell, so thanks for taking the time to help out, Chris. -- AlsonKemp<br />
<br />
[[TableOfContents]]<br />
<br />
= Description =<br />
The description on the Shootout page is pretty minimal, so refer to other implementations for guidance. The "D" entry is [http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=dlang&id=0 here] and the OCaml entry is [http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=ocaml&id=0 here].<br />
<br />
Simulate a hierarchical healthcare system, with patient transfers from lower-level district hospitals to higher-level regional hospitals.<br />
<br />
Each healthcare region<br />
* has a reference to one local hospital<br />
* has 4 subregions<br />
* gathers transfer patients from the 4 subregions<br />
<br />
Each hospital<br />
* has 0.3 new patient arrivals per time period<br />
* has additional transfer patient arrivals<br />
* manages 3 patient queues - triage, examination, treatment (Patient queues must be implemented as a linked list, with na�ve add patient and remove patient operations.)<br />
<br />
Each patient<br />
* arriving at the highest-level regional hospital will be treated<br />
* arriving at a district hospital has 0.9 probability of being treated without transfer from that hospital<br />
<br />
Correct output N = 100 is:<br />
<br />
Patients: 10151<br />
Time: 363815<br />
Visits: 10526<br />
<br />
Treatment Queue - Remaining Treatment Time<br />
1 anonymous patient<br />
3 anonymous patient<br />
9 anonymous patient<br />
10 anonymous patient<br />
<br />
<br />
This is a simplified version of the health benchmark in the Olden Benchmark Suite and Jolden Benchmarks.<br />
<br />
The original reference seems to be G. Lomow, J. Cleary, B. Unger and D. West. "A Performance Study of Time Warp" SCS Multiconference on Distributed Simulation, pages 50-55, Feb. 1988.<br />
<br />
= Entry =<br />
Bueller... Bueller...<br />
<br />
<br />
''I will try and make ''''something'''' from the other code that produces the correct output in Haskell.'' --Chris Kuklewicz<br />
<br />
By far the biggest problem is that this is another '''pseudo-random''' driven benchmark. So all of those random decisions have to be taken in exactly the same order as every other program to produce the correct output. This will heavily restrict what code we can write.<br />
<br />
The second issue is it specifies mutable singly linked lists. I think the data can be fixed, and we can use an IORef for the "next" pointer.<br />
<br />
== IO Entry #2 ==<br />
<br />
This is a much much more efficient version of IO Entry #1. Off-by-one errors took their toll in debugging, but the performance is worth it. While being transferred between lists, the order of patients does not matter.<br />
<br />
Compile : "ghc -optc-O3 -fglasgow-exts -funbox-strict-fields -O2 limbo-3j.hs -o limbo-3j"<br />
Run : "./limbo-3j +RTS -H100M -RTS 1000"<br />
<br />
<haskell><br />
-- limbo-3j.hs<br />
--<br />
-- The Great Computer Language Shootout<br />
-- http://shootout.alioth.debian.org/<br />
--<br />
-- Haskell Wiki page for Shootout entries - http://haskell.org/hawiki/ShootoutEntry<br />
--<br />
-- The "health" benchmark, currently alpha in the sandbox:<br />
-- http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=all<br />
--<br />
-- Contributed by Chris Kuklewicz<br />
--<br />
-- modeled after the OCaml entry by Troestler Christophe<br />
--<br />
import Control.Monad<br />
import Data.Array<br />
import Data.Bits(shiftL)<br />
import Data.IORef<br />
import Data.Ix<br />
import Data.List<br />
import System(getArgs)<br />
import Text.Printf(printf)<br />
<br />
default ()<br />
<br />
levels = 5<br />
districts = 4<br />
<br />
-- Create a PRNG command from a seed, discard first seed<br />
<br />
prng :: Int -> IO (IO Double)<br />
prng seed = do ref <- newIORef (nextSeed seed)<br />
return $ do s <- readIORef ref<br />
writeIORef ref $ nextSeed s<br />
return $ im' * fromIntegral s<br />
where (im,ia,ic,im')=(139968,3877,29573,recip $ fromIntegral im)<br />
nextSeed s = (s * ia + ic) `mod` im<br />
<br />
-- LinkedList data type we can append to and delete from middle of<br />
-- LL firstRef lastRef<br />
-- firstRef points at Nothing if empty<br />
-- otherwise firstRef points at the first Node<br />
-- invariant: lastRef always points at an Link that points at Nothing<br />
<br />
--data LinkedList a = LL !(Link a) !(IORef (Link a))<br />
--type Link a = IORef (Maybe (Node a))<br />
--data Node a = Node !a !(Link a)<br />
<br />
-- Alternative is<br />
data LinkedList a = LL !(Link a) !(IORef (Link a))<br />
type Link a = IORef (Node a)<br />
data Node a = Node !a !(Link a) | NoNode <br />
<br />
newLL = do first <- newIORef NoNode<br />
last <- newIORef first<br />
return $ LL first last<br />
<br />
-- addN assume link is a IORef that holds NoNode<br />
addN :: LinkedList a -> Node a -> IO ()<br />
addN (LL first last) node@(Node _ link) = do<br />
temp <- readIORef last<br />
writeIORef temp node<br />
writeIORef last link<br />
<br />
takeLL :: Int -> LinkedList a -> IO (Int,[Node a])<br />
takeLL s (LL first last) = do<br />
let loop :: Link a -> [Node a] -> Int -> IO (Int,[Node a],Link a)<br />
loop ref xs i | i == s = return (i,xs,ref)<br />
| otherwise = do mNode <- readIORef ref<br />
case mNode of <br />
NoNode -> return (i,xs,ref)<br />
Node _ next -> loop next (mNode:xs) (succ i)<br />
<br />
(j,ns,ref) <- loop first [] 0<br />
mFirst <- readIORef ref<br />
writeIORef first mFirst<br />
case mFirst of NoNode -> (writeIORef last first); _ -> return ()<br />
return (j,ns)<br />
<br />
deleteAllBy :: (Node a -> IO Bool) -> (LinkedList a) -> IO ()<br />
{-# NOINLINE deleteAllBy #-}<br />
deleteAllBy f ll@(LL first last) = do<br />
let loop ref node@(Node _ next) = do<br />
mNext <- readIORef next<br />
keep <- f node<br />
case mNext of<br />
NoNode -> if keep then return ()<br />
else do writeIORef ref NoNode<br />
writeIORef last ref<br />
node' -> if keep then loop next node'<br />
else do writeIORef ref mNext<br />
loop ref node'<br />
mFirst <- readIORef first<br />
case mFirst of NoNode -> return ()<br />
firstNode -> loop first firstNode<br />
<br />
foldLL :: (b->a->IO b) -> LinkedList a -> b -> IO b<br />
foldLL f (LL first _) b = foldLL' b first<br />
where foldLL' b ref = do<br />
mNode <- readIORef ref<br />
case mNode of<br />
NoNode -> return b<br />
Node a next -> do<br />
b' <- f b a<br />
foldLL' b' next<br />
<br />
forEachLL :: (a -> IO b) -> LinkedList a -> IO ()<br />
forEachLL f (LL first _) = forEachLL' first<br />
where forEachLL' ref = do<br />
mNode <- readIORef ref<br />
case mNode of<br />
NoNode -> return ()<br />
Node a next -> f a >> forEachLL' next<br />
<br />
-- Patient data type<br />
<br />
data Patient = Patient {countdown :: !(IORef Int)<br />
,totalTime :: !(IORef Int)<br />
,visits :: !(IORef Int)}<br />
<br />
makePatient :: IO Patient<br />
makePatient = liftM3 Patient (newIORef 0) (newIORef 0) (newIORef 1)<br />
<br />
-- Stats data type <br />
<br />
data Stats = Stats !Int !Int !Int deriving Show<br />
<br />
(Stats p t v) +++ (Stats p' t' v') = Stats (p+p') (t+t') (v+v')<br />
<br />
-- Joint Patient and Stats operation<br />
<br />
addPatient :: Stats -> Patient -> IO Stats<br />
addPatient (Stats p t v) patient = do<br />
t' <- readIORef (totalTime patient)<br />
v' <- readIORef (visits patient)<br />
return (Stats (succ p) (t+t') (v+v'))<br />
<br />
-- Hospital data type<br />
<br />
data Hospital = Hospital {topLevel :: Bool <br />
,random :: (IO Double)<br />
,staff :: IORef Int<br />
,triage :: LinkedList Patient<br />
,examination :: LinkedList Patient<br />
,treatment :: LinkedList Patient<br />
,statistics :: IORef Stats<br />
}<br />
<br />
makeHospital :: Int -> IO Double -> IO Hospital<br />
makeHospital level rand = do <br />
staff' <- newIORef (1 `shiftL` (pred level))<br />
[triage',examination',treatment'] <- replicateM 3 newLL<br />
statistics' <- newIORef (Stats 0 0 0)<br />
return $ Hospital (level==levels) rand staff' triage' examination' treatment' statistics'<br />
<br />
-- Region data type<br />
<br />
data Region = Region Hospital (Maybe (Array Int Region))<br />
<br />
makeRegion :: Int -> Int -> Int -> IO Region<br />
makeRegion level seed1 seed2 = do<br />
localHospital <- makeHospital level =<< (prng ( seed1*seed2 ))<br />
if level == 1 then return $ Region localHospital Nothing<br />
else let createSub i = liftM ((,) i) $ makeRegion (pred level) ((4*seed1) + i + 1) seed2<br />
in liftM ( (Region localHospital).Just.(array (0,pred districts)) ) $ mapM createSub [0..pred districts]<br />
<br />
-- Main Program<br />
<br />
-- Assume links of nodes point to nothing<br />
doStepHospital :: Int -> Hospital -> [Node Patient] -> IO [Node Patient]<br />
doStepHospital now hospital newPatients = do<br />
out <- newIORef []<br />
let newArrivals :: [Node Patient] -> Int -> IO ()<br />
newArrivals [] s = {-# SCC "newArrivals-3" #-} writeIORef (staff hospital) s<br />
newArrivals nps 0 = {-# SCC "newArrivals-2" #-} do -- no staff, triage the rest<br />
sequence_ [ (do modifyIORef (visits p) succ <br />
writeIORef (countdown p) now<br />
addN (triage hospital) np<br />
) | np@(Node p _) <- nps]<br />
writeIORef (staff hospital) 0<br />
newArrivals (np@(Node p _):ps) s = {-# SCC "newArrivals-1" #-} do -- some staff, examine patient<br />
modifyIORef (visits p) succ<br />
modifyIORef (totalTime p) (+3)<br />
writeIORef (countdown p) (now+2) -- XXX<br />
addN (examination hospital) np<br />
newArrivals ps $! pred s<br />
<br />
treatPatient :: Node Patient -> IO Bool<br />
treatPatient (Node p _) = {-# SCC "treatPatient" #-} do <br />
t <- readIORef (countdown p)<br />
if t==now then do addStat p<br />
modifyIORef (staff hospital) succ<br />
return False -- patient is cured<br />
else do return True -- continue treatment<br />
<br />
addStat :: Patient -> IO ()<br />
addStat patient = {-# SCC "addStat" #-} do<br />
s0 <- readIORef (statistics hospital)<br />
s1 <- addPatient s0 patient<br />
writeIORef (statistics hospital) s1<br />
<br />
examinePatient :: Node Patient -> IO Bool<br />
examinePatient np@(Node p link) = {-# SCC "diagnosePatient" #-} do<br />
t <- readIORef (countdown p)<br />
if t==now<br />
then do<br />
writeIORef link NoNode<br />
decide <- (random hospital)<br />
if (decide > 0.1) || (topLevel hospital)<br />
then do<br />
modifyIORef (totalTime p) (+10)<br />
writeIORef (countdown p) (now+10)<br />
addN (treatment hospital) np<br />
else do<br />
modifyIORef (staff hospital) succ<br />
modifyIORef out (np:)<br />
return False<br />
else do <br />
return True<br />
<br />
doTriage :: IO ()<br />
doTriage = do <br />
s <- readIORef (staff hospital)<br />
when (s>0) $ do<br />
(j,nps) <- takeLL s (triage hospital)<br />
writeIORef (staff hospital) (s-j)<br />
sequence_ [ (do oldNow <- readIORef (countdown p)<br />
modifyIORef (totalTime p) (+ (now - oldNow+3))<br />
writeIORef (countdown p) (now+3) -- XXX<br />
writeIORef link NoNode<br />
addN (examination hospital) np) | np@(Node p link) <- nps]<br />
<br />
maybeNewPatient :: IO ()<br />
maybeNewPatient = {-# SCC "maybeNewPatient" #-} do<br />
decide <- random hospital<br />
when (decide > 0.7) $ do<br />
p <- makePatient<br />
np <- liftM (Node p) (newIORef NoNode)<br />
s <- readIORef (staff hospital)<br />
if s==0 then do writeIORef (countdown p) (succ now)<br />
addN (triage hospital) np<br />
else do writeIORef (staff hospital) (pred s)<br />
modifyIORef (totalTime p) (+3)<br />
writeIORef (countdown p) (now+3) -- XXX<br />
addN (examination hospital) np<br />
return ()<br />
<br />
{-# SCC "do1" #-} (newArrivals newPatients =<< readIORef (staff hospital))<br />
{-# SCC "do2" #-} deleteAllBy treatPatient (treatment hospital)<br />
{-# SCC "do3" #-} deleteAllBy examinePatient (examination hospital)<br />
{-# SCC "do4" #-} doTriage<br />
maybeNewPatient<br />
readIORef out<br />
<br />
doTransferPatients :: Int -> Region -> IO [Node Patient]<br />
doTransferPatients now (Region hospital mSubs) = do<br />
transfers <- maybe (return []) ((mapM (doTransferPatients now)).elems) mSubs<br />
doStepHospital now hospital (concat transfers)<br />
<br />
total :: Int -> Stats -> Region -> IO Stats<br />
total now s (Region hospital mSubs) = do<br />
let fixTriage p = do oldNow <- readIORef (countdown p)<br />
modifyIORef (totalTime p) (+ ((succ now)-oldNow))<br />
forEachLL fixTriage (triage hospital) <br />
readIORef (statistics hospital) >>=<br />
foldLL addPatient (triage hospital) >>=<br />
foldLL addPatient (examination hospital) >>=<br />
foldLL addPatient (treatment hospital) >>=<br />
(\n ->foldM (total now) n (maybe [] elems mSubs)) >>=<br />
return.(s+++)<br />
<br />
printQueue :: Int -> Region -> IO ()<br />
printQueue now (Region hospital _) = do<br />
let out ::Patient -> IO Bool<br />
out p = do<br />
t <- readIORef (countdown p)<br />
printf "%d\tanonymous patient\n" (t-now)<br />
return True<br />
forEachLL out (treatment hospital)<br />
<br />
<br />
main = do n <- getArgs >>= \ns -> return $ if null ns then 100 else read (head ns)<br />
region@(Region hospital _) <- makeRegion levels 0 42<br />
let loop k | seq k True = if k<=n then doTransferPatients k region >> loop (succ k)<br />
else return []<br />
loop 1<br />
(Stats p t v) <- total n (Stats 0 0 0) region<br />
printf "Patients: %d\nTime: %d\nVisits: %d\n" p t v<br />
putStrLn "\nTreatment Queue - Remaining Treatment Time"<br />
printQueue n region <br />
</haskell><br />
<br />
== IO Entry #1 ==<br />
<br />
This is very very close to the OCaml entry but runs much much slower<br />
<br />
On the plus side, it gets the right answers. Diagnostic argument is 100, benchmark argument is 1000.<br />
<br />
<haskell><br />
-- health.hs<br />
--<br />
-- The Great Computer Language Shootout<br />
-- http://shootout.alioth.debian.org/<br />
--<br />
-- Haskell Wiki page for Shootout entries - http://haskell.org/hawiki/ShootoutEntry<br />
--<br />
-- The "health" benchmark, currently alpha in the sandbox:<br />
-- http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=all<br />
--<br />
-- Contributed by Chris Kuklewicz<br />
--<br />
-- modeled after the OCaml entry by Troestler Christophe<br />
--<br />
import Control.Monad<br />
import Data.Array<br />
import Data.Bits(shiftL)<br />
import Data.IORef<br />
import Data.Ix<br />
import Data.List<br />
import System(getArgs)<br />
import Text.Printf(printf)<br />
<br />
levels = 5<br />
districts = 4<br />
<br />
-- Create a PRNG command from a seed, discard first seed<br />
<br />
prng :: Int -> IO (IO Double)<br />
prng seed = do ref <- newIORef (nextSeed seed)<br />
return $ do s <- readIORef ref<br />
writeIORef ref $ nextSeed s<br />
return $ im' * fromIntegral s<br />
where (im,ia,ic,im')=(139968,3877,29573,recip $ fromIntegral im)<br />
nextSeed s = (s * ia + ic) `mod` im<br />
<br />
-- LinkedList data type we can append to and delete from middle of<br />
-- LL firstRef lastRef<br />
-- firstRef points at Nothing if empty<br />
-- otherwise firstRef points at the first Node<br />
-- invariant: lastRef always points at an Link that points at Nothing<br />
<br />
data LinkedList a = LL !(Link a) !(IORef (Link a))<br />
type Link a = IORef (Maybe (Node a))<br />
data Node a = Node !a !(Link a)<br />
<br />
-- Alternative is<br />
-- data LinkedList a = LL (Link a) (IORef (Link a))<br />
-- type Link a = IORef (Node a)<br />
-- data Node = Node a (Link a) | NoNode<br />
<br />
newLL = do first <- newIORef Nothing<br />
last <- newIORef first<br />
return $ LL first last<br />
<br />
-- diagnostic -- not used in benchmark<br />
lengthLL (LL first _) = loop first 0<br />
where loop ref i = do<br />
mNode <- readIORef ref<br />
case mNode of<br />
Nothing -> return i<br />
Just (Node _ next) -> loop next $! succ i<br />
<br />
-- addN assume link is a IORef that holds Nothing<br />
addN :: LinkedList a -> Node a -> IO ()<br />
addN (LL first last) node@(Node _ link) = do<br />
let mNode = Just node<br />
temp <- readIORef last<br />
writeIORef temp mNode<br />
writeIORef last link<br />
<br />
deleteAllBy :: (Node a -> IO Bool) -> (LinkedList a) -> IO ()<br />
deleteAllBy f ll@(LL first last) = do<br />
let loop ref node@(Node _ next) = do<br />
mNext <- readIORef next<br />
keep <- f node<br />
case (keep,mNext) of<br />
(True,Nothing) -> return () -- keep end of list<br />
(True,Just node') -> loop next node' -- keep<br />
(False,Nothing) -> do writeIORef ref Nothing -- delete end of list<br />
writeIORef last ref<br />
(False,Just node') -> do writeIORef ref mNext -- delete<br />
loop ref node'<br />
mFirst <- readIORef first<br />
case mFirst of Nothing -> return ()<br />
Just firstNode -> loop first firstNode<br />
<br />
foldLL :: (b->a->IO b) -> b -> (LinkedList a) -> IO b<br />
foldLL f b (LL first _) = foldLL' b first<br />
where foldLL' b ref = do<br />
mNode <- readIORef ref<br />
case mNode of<br />
Nothing -> return b<br />
Just (Node a next) -> do<br />
b' <- f b a<br />
foldLL' b' next<br />
<br />
forEachLL :: (a -> IO b) -> LinkedList a -> IO ()<br />
forEachLL f (LL first _) = forEachLL' first<br />
where forEachLL' ref = do<br />
mNode <- readIORef ref<br />
case mNode of<br />
Nothing -> return ()<br />
Just (Node a next) -> f a >> forEachLL' next<br />
<br />
-- Patient data type<br />
<br />
data Patient = Patient {countdown :: IORef Int<br />
,totalTime :: IORef Int<br />
,visits :: IORef Int}<br />
<br />
makePatient :: IO Patient<br />
makePatient = liftM3 Patient (newIORef 0) (newIORef 0) (newIORef 0)<br />
<br />
patientStay :: Patient -> Int -> IO ()<br />
patientStay p t = do <br />
writeIORef (countdown p) t<br />
modifyIORef (totalTime p) (+t)<br />
<br />
-- Stats data type <br />
<br />
data Stats = Stats !Int !Int !Int deriving Show<br />
<br />
(Stats p t v) +++ (Stats p' t' v') = Stats (p+p') (t+t') (v+v')<br />
<br />
-- Joint Patient and Stats operation<br />
<br />
addPatient :: Stats -> Patient -> IO Stats<br />
addPatient (Stats p t v) patient = do<br />
t' <- readIORef (totalTime patient)<br />
v' <- readIORef (visits patient)<br />
return (Stats (succ p) (t+t') (v+v'))<br />
<br />
-- Hospital data type<br />
<br />
data Hospital = Hospital {topLevel :: Bool <br />
,random :: (IO Double)<br />
,staff :: IORef Int<br />
,triage :: LinkedList Patient<br />
,examination :: LinkedList Patient<br />
,treatment :: LinkedList Patient<br />
,statistics :: IORef Stats<br />
}<br />
<br />
makeHospital :: Int -> IO Double -> IO Hospital<br />
makeHospital level rand = do <br />
staff' <- newIORef (1 `shiftL` (pred level))<br />
[triage',examination',treatment'] <- replicateM 3 newLL<br />
statistics' <- newIORef (Stats 0 0 0)<br />
return $ Hospital (level==levels) rand staff' triage' examination' treatment' statistics'<br />
<br />
-- Region data type<br />
<br />
data Region = Region Hospital (Maybe (Array Int Region))<br />
<br />
makeRegion :: Int -> Int -> Int -> IO Region<br />
makeRegion level seed1 seed2 = do<br />
localHospital <- makeHospital level =<< (prng ( seed1*seed2 ))<br />
if level == 1 then return $ Region localHospital Nothing<br />
else let createSub i = liftM ((,) i) $ makeRegion (pred level) ((4*seed1) + i + 1) seed2<br />
in liftM ( (Region localHospital).Just.(array (0,pred districts)) ) $ mapM createSub [0..pred districts]<br />
<br />
-- Main Program<br />
<br />
-- Assume links of nodes point to nothing<br />
doStepHospital :: Hospital -> [Node Patient] -> IO [Node Patient]<br />
doStepHospital hospital newPatients = do<br />
out <- newIORef []<br />
let newArrivals :: [Node Patient] -> Int -> IO ()<br />
newArrivals [] s = writeIORef (staff hospital) s<br />
newArrivals nps 0 = do -- no staff, triage the rest<br />
sequence_ [ modifyIORef (visits p) succ >> addN (triage hospital) np | np@(Node p _) <- nps]<br />
writeIORef (staff hospital) 0<br />
newArrivals (np@(Node p _):ps) s = do -- some staff, examine patient<br />
modifyIORef (visits p) succ<br />
patientStay p 3<br />
addN (examination hospital) np<br />
newArrivals ps $! pred s<br />
<br />
treatPatient :: Node Patient -> IO Bool<br />
treatPatient (Node p _) = do <br />
t <- readIORef (countdown p)<br />
if t==1 then do addStat p<br />
modifyIORef (staff hospital) succ<br />
return False -- patient is cured<br />
else do writeIORef (countdown p) (pred t)<br />
return True -- continue treatment<br />
<br />
addStat :: Patient -> IO ()<br />
addStat patient = do<br />
s0 <- readIORef (statistics hospital)<br />
s1 <- addPatient s0 patient<br />
writeIORef (statistics hospital) s1<br />
<br />
diagnosePatient :: Node Patient -> IO Bool<br />
diagnosePatient np@(Node p link) = do<br />
t <- readIORef (countdown p)<br />
if t==1 <br />
then do<br />
writeIORef link Nothing<br />
decide <- (random hospital)<br />
if (decide > 0.1) || (topLevel hospital)<br />
then do<br />
patientStay p 10<br />
-- staff does not change<br />
addN (treatment hospital) np<br />
else do<br />
modifyIORef (staff hospital) succ<br />
modifyIORef out (np:)<br />
return False<br />
else do <br />
writeIORef (countdown p) (pred t)<br />
return True<br />
<br />
triagePatient :: Node Patient -> IO Bool<br />
triagePatient np@(Node p link) = do<br />
s <- readIORef (staff hospital)<br />
if s > 0<br />
then do<br />
writeIORef (staff hospital) (pred s)<br />
writeIORef link Nothing<br />
patientStay p 3<br />
addN (examination hospital) np<br />
return False<br />
else do<br />
modifyIORef (totalTime p) succ<br />
return True<br />
<br />
maybeNewPatient :: IO ()<br />
maybeNewPatient = do<br />
decide <- random hospital<br />
when (decide > 0.7) $ do<br />
np <- liftM2 Node makePatient (newIORef Nothing)<br />
newArrivals [np] =<< readIORef (staff hospital)<br />
return () <br />
<br />
newArrivals newPatients =<< readIORef (staff hospital)<br />
deleteAllBy treatPatient (treatment hospital)<br />
deleteAllBy diagnosePatient (examination hospital)<br />
deleteAllBy triagePatient (triage hospital)<br />
maybeNewPatient<br />
readIORef out<br />
<br />
doTransferPatients :: Region -> IO [Node Patient]<br />
doTransferPatients (Region hospital mSubs) = do<br />
transfers <- maybe (return []) ((mapM doTransferPatients).elems) mSubs<br />
doStepHospital hospital (concat transfers)<br />
<br />
total :: Stats -> Region -> IO Stats<br />
total s (Region hospital mSubs) = do<br />
n0 <- readIORef (statistics hospital)<br />
n1 <- foldLL addPatient n0 (triage hospital)<br />
n2 <- foldLL addPatient n1 (examination hospital)<br />
n3 <- foldLL addPatient n2 (treatment hospital)<br />
n4 <- foldM total n3 (maybe [] elems mSubs)<br />
return (s+++n4)<br />
<br />
printQueue (Region hospital _) = do<br />
let out ::Patient -> IO Bool<br />
out p = do<br />
t <- readIORef (countdown p)<br />
printf "%d\tanonymous patient\n" t<br />
return True<br />
forEachLL out (treatment hospital)<br />
<br />
-- Just diagnostic -- not used in benchmark<br />
displayH :: Hospital -> IO ()<br />
displayH hospital = do<br />
let t = topLevel hospital<br />
s <- readIORef (staff hospital)<br />
ltriage <- lengthLL (triage hospital)<br />
lexamination <- lengthLL (examination hospital)<br />
ltreatment <- lengthLL (treatment hospital)<br />
stats <- readIORef (statistics hospital)<br />
print ("Hospital : "++show t)<br />
putStrLn (unwords $ map show [s,ltriage,lexamination,ltreatment])<br />
print stats<br />
<br />
main = do ns <- getArgs<br />
let n :: Int<br />
n = if null ns then 100 else read (head ns)<br />
region@(Region hospital _) <- makeRegion levels 0 42<br />
replicateM_ n (doTransferPatients region)<br />
(Stats p t v) <- total (Stats 0 0 0) region<br />
printf "Patients: %d\nTime: %d\nVisits: %d\n" p t v<br />
putStrLn "\nTreatment Queue - Remaining Treatment Time"<br />
printQueue region <br />
</haskell><br />
<br />
[[Category:Code]]</div>
DonStewart