# Shootout/Healthcare

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

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

# Description

The description on the Shootout page is pretty minimal, so refer to other implementations for guidance. The "D" entry is here and the OCaml entry is here.

Simulate a hierarchical healthcare system, with patient transfers from lower-level district hospitals to higher-level regional hospitals.

Each healthcare region

• has a reference to one local hospital
• has 4 subregions
• gathers transfer patients from the 4 subregions

Each hospital

• has 0.3 new patient arrivals per time period
• has additional transfer patient arrivals
• 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.)

Each patient

• arriving at the highest-level regional hospital will be treated
• arriving at a district hospital has 0.9 probability of being treated without transfer from that hospital

Correct output N = 100 is:

```   Patients: 10151
Time:     363815
Visits:   10526
```
```   Treatment Queue - Remaining Treatment Time
1       anonymous patient
3       anonymous patient
9       anonymous patient
10      anonymous patient
```

This is a simplified version of the health benchmark in the Olden Benchmark Suite and Jolden Benchmarks.

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.

# Entry

Bueller... Bueller...

I will try and make 'something' from the other code that produces the correct output in Haskell. --Chris Kuklewicz

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.

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.

## IO Entry #2

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.

Compile : "ghc -optc-O3 -fglasgow-exts -funbox-strict-fields -O2 limbo-3j.hs -o limbo-3j" Run : "./limbo-3j +RTS -H100M -RTS 1000"

```-- limbo-3j.hs
--
-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
--
-- The "health" benchmark, currently alpha in the sandbox:
-- http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=all
--
-- Contributed by Chris Kuklewicz
--
-- modeled after the OCaml entry by Troestler Christophe
--
import Data.Array
import Data.Bits(shiftL)
import Data.IORef
import Data.Ix
import Data.List
import System(getArgs)
import Text.Printf(printf)

default ()

levels = 5
districts = 4

-- Create a PRNG command from a seed, discard first seed

prng :: Int -> IO (IO Double)
prng seed = do ref <- newIORef (nextSeed seed)
return \$ do s <- readIORef ref
writeIORef ref \$ nextSeed s
return \$ im' * fromIntegral s
where (im,ia,ic,im')=(139968,3877,29573,recip \$ fromIntegral im)
nextSeed s = (s * ia + ic) `mod` im

-- LinkedList data type we can append to and delete from middle of
-- LL firstRef lastRef
-- firstRef points at Nothing if empty
--          otherwise firstRef points at the first Node
-- invariant: lastRef always points at an Link that points at Nothing

--type Link a = IORef (Maybe (Node a))
--data Node a = Node !a !(Link a)

-- Alternative is
type Link a = IORef (Node a)
data Node a = Node !a !(Link a) | NoNode

newLL = do first <- newIORef NoNode
last <- newIORef first
return \$ LL first last

writeIORef temp node

takeLL :: Int -> LinkedList a -> IO (Int,[Node a])
takeLL s (LL first last) = do
let loop :: Link a -> [Node a] -> Int -> IO (Int,[Node a],Link a)
loop ref xs i | i == s = return (i,xs,ref)
| otherwise = do mNode <- readIORef ref
case mNode of
NoNode -> return (i,xs,ref)
Node _ next -> loop next (mNode:xs) (succ i)

(j,ns,ref) <- loop first [] 0
writeIORef first mFirst
case mFirst of NoNode -> (writeIORef last first); _ -> return ()
return (j,ns)

deleteAllBy :: (Node a -> IO Bool) -> (LinkedList a) -> IO ()
{-# NOINLINE deleteAllBy #-}
deleteAllBy f ll@(LL first last) = do
let loop ref node@(Node _ next) = do
keep <- f node
case mNext of
NoNode -> if keep then return ()
else do writeIORef ref NoNode
writeIORef last ref
node' -> if keep then loop next node'
else do writeIORef ref mNext
loop ref node'
case mFirst of NoNode -> return ()
firstNode -> loop first firstNode

foldLL :: (b->a->IO b) -> LinkedList a -> b -> IO b
foldLL f  (LL first _) b = foldLL' b first
where foldLL' b ref = do
case mNode of
NoNode -> return b
Node a next -> do
b' <- f b a
foldLL' b' next

forEachLL :: (a -> IO b) -> LinkedList a -> IO ()
forEachLL f (LL first _) = forEachLL' first
where forEachLL' ref = do
case mNode of
NoNode -> return ()
Node a next -> f a >> forEachLL' next

-- Patient data type

data Patient = Patient {countdown :: !(IORef Int)
,totalTime :: !(IORef Int)
,visits :: !(IORef Int)}

makePatient :: IO Patient
makePatient = liftM3 Patient (newIORef 0) (newIORef 0) (newIORef 1)

-- Stats data type

data Stats = Stats !Int !Int !Int deriving Show

(Stats p t v) +++ (Stats p' t' v') = Stats (p+p') (t+t') (v+v')

-- Joint Patient and Stats operation

addPatient :: Stats -> Patient -> IO Stats
addPatient (Stats p t v) patient = do
return (Stats (succ p) (t+t') (v+v'))

-- Hospital data type

data Hospital = Hospital {topLevel :: Bool
,random :: (IO Double)
,staff :: IORef Int
,statistics :: IORef Stats
}

makeHospital :: Int -> IO Double -> IO Hospital
makeHospital level rand = do
staff' <- newIORef (1 `shiftL` (pred level))
[triage',examination',treatment'] <- replicateM 3 newLL
statistics' <- newIORef (Stats 0 0 0)
return \$ Hospital (level==levels) rand staff' triage' examination' treatment' statistics'

-- Region data type

data Region = Region Hospital (Maybe (Array Int Region))

makeRegion :: Int -> Int -> Int -> IO Region
makeRegion level seed1 seed2 = do
localHospital <- makeHospital level =<< (prng ( seed1*seed2 ))
if level == 1 then return \$ Region localHospital Nothing
else let createSub i = liftM ((,) i) \$ makeRegion (pred level) ((4*seed1) + i + 1) seed2
in liftM ( (Region localHospital).Just.(array (0,pred districts)) ) \$ mapM createSub [0..pred districts]

-- Main Program

-- Assume links of nodes point to nothing
doStepHospital :: Int -> Hospital -> [Node Patient] -> IO [Node Patient]
doStepHospital now hospital newPatients = do
out <- newIORef []
let newArrivals :: [Node Patient] -> Int -> IO ()
newArrivals [] s = {-# SCC "newArrivals-3" #-} writeIORef (staff hospital) s
newArrivals nps 0 = {-# SCC "newArrivals-2" #-} do -- no staff, triage the rest
sequence_ [ (do modifyIORef (visits p) succ
writeIORef (countdown p) now
) | np@(Node p _) <- nps]
writeIORef (staff hospital) 0
newArrivals (np@(Node p _):ps) s = {-# SCC "newArrivals-1" #-} do -- some staff, examine patient
modifyIORef (visits p) succ
modifyIORef (totalTime p) (+3)
writeIORef (countdown p) (now+2) -- XXX
newArrivals ps \$! pred s

treatPatient :: Node Patient -> IO Bool
treatPatient (Node p _) = {-# SCC "treatPatient" #-} do
if t==now then do addStat p
modifyIORef (staff hospital) succ
return False -- patient is cured
else do return True -- continue treatment

addStat :: Patient -> IO ()
writeIORef (statistics hospital) s1

examinePatient :: Node Patient -> IO Bool
examinePatient np@(Node p link) = {-# SCC "diagnosePatient" #-} do
if t==now
then do
decide <- (random hospital)
if (decide > 0.1) || (topLevel hospital)
then do
modifyIORef (totalTime p) (+10)
writeIORef (countdown p) (now+10)
else do
modifyIORef (staff hospital) succ
modifyIORef out (np:)
return False
else do
return True

doTriage :: IO ()
doTriage = do
when (s>0) \$ do
(j,nps) <- takeLL s (triage hospital)
writeIORef (staff hospital) (s-j)
sequence_ [ (do oldNow <- readIORef (countdown p)
modifyIORef (totalTime p) (+ (now - oldNow+3))
writeIORef (countdown p) (now+3) -- XXX

maybeNewPatient :: IO ()
maybeNewPatient = {-# SCC "maybeNewPatient" #-} do
decide <- random hospital
when (decide > 0.7) \$ do
p <- makePatient
np <- liftM (Node p) (newIORef NoNode)
if s==0 then do writeIORef (countdown p) (succ now)
else do writeIORef (staff hospital) (pred s)
modifyIORef (totalTime p) (+3)
writeIORef (countdown p) (now+3) --  XXX
return ()

{-# SCC "do1" #-} (newArrivals newPatients =<< readIORef (staff hospital))
{-# SCC "do2" #-} deleteAllBy treatPatient (treatment hospital)
{-# SCC "do3" #-} deleteAllBy examinePatient (examination hospital)
{-# SCC "do4" #-} doTriage
maybeNewPatient

doTransferPatients :: Int -> Region -> IO [Node Patient]
doTransferPatients now (Region hospital mSubs) = do
transfers <- maybe (return []) ((mapM (doTransferPatients now)).elems) mSubs
doStepHospital now hospital (concat transfers)

total :: Int -> Stats -> Region -> IO Stats
total now s (Region hospital mSubs) = do
let fixTriage p = do oldNow <- readIORef (countdown p)
modifyIORef (totalTime p) (+ ((succ now)-oldNow))
forEachLL fixTriage (triage hospital)
(\n ->foldM (total now) n (maybe [] elems mSubs)) >>=
return.(s+++)

printQueue :: Int -> Region -> IO ()
printQueue now (Region hospital _) = do
let out ::Patient -> IO Bool
out p = do
printf "%d\tanonymous patient\n" (t-now)
return True
forEachLL out (treatment hospital)

main = do n <- getArgs >>= \ns -> return \$ if null ns then 100 else read (head ns)
region@(Region hospital _) <- makeRegion levels 0 42
let loop k | seq k True = if k<=n then doTransferPatients k region >> loop (succ k)
else return []
loop 1
(Stats p t v) <- total n (Stats 0 0 0) region
printf "Patients: %d\nTime:     %d\nVisits:   %d\n" p t v
putStrLn "\nTreatment Queue - Remaining Treatment Time"
printQueue n region
```

## IO Entry #1

This is very very close to the OCaml entry but runs much much slower

On the plus side, it gets the right answers. Diagnostic argument is 100, benchmark argument is 1000.

```-- health.hs
--
-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
--
-- The "health" benchmark, currently alpha in the sandbox:
-- http://shootout.alioth.debian.org/sandbox/benchmark.php?test=health&lang=all
--
-- Contributed by Chris Kuklewicz
--
-- modeled after the OCaml entry by Troestler Christophe
--
import Data.Array
import Data.Bits(shiftL)
import Data.IORef
import Data.Ix
import Data.List
import System(getArgs)
import Text.Printf(printf)

levels = 5
districts = 4

-- Create a PRNG command from a seed, discard first seed

prng :: Int -> IO (IO Double)
prng seed = do ref <- newIORef (nextSeed seed)
return \$ do s <- readIORef ref
writeIORef ref \$ nextSeed s
return \$ im' * fromIntegral s
where (im,ia,ic,im')=(139968,3877,29573,recip \$ fromIntegral im)
nextSeed s = (s * ia + ic) `mod` im

-- LinkedList data type we can append to and delete from middle of
-- LL firstRef lastRef
-- firstRef points at Nothing if empty
--          otherwise firstRef points at the first Node
-- invariant: lastRef always points at an Link that points at Nothing

type Link a = IORef (Maybe (Node a))
data Node a = Node !a !(Link a)

-- Alternative is
-- type Link a = IORef (Node a)
-- data Node = Node a (Link a) | NoNode

newLL = do first <- newIORef Nothing
last <- newIORef first
return \$ LL first last

-- diagnostic -- not used in benchmark
lengthLL (LL first _) = loop first 0
where loop ref i = do
case mNode of
Nothing -> return i
Just (Node _ next) -> loop next \$! succ i

let mNode = Just node
writeIORef temp mNode

deleteAllBy :: (Node a -> IO Bool) -> (LinkedList a) -> IO ()
deleteAllBy f ll@(LL first last) = do
let loop ref node@(Node _ next) = do
keep <- f node
case (keep,mNext) of
(True,Nothing) -> return () -- keep end of list
(True,Just node') -> loop next node' -- keep
(False,Nothing) -> do writeIORef ref Nothing -- delete end of list
writeIORef last ref
(False,Just node') -> do writeIORef ref mNext -- delete
loop ref node'
case mFirst of Nothing -> return ()
Just firstNode -> loop first firstNode

foldLL :: (b->a->IO b) -> b -> (LinkedList a) -> IO b
foldLL f b (LL first _) = foldLL' b first
where foldLL' b ref = do
case mNode of
Nothing -> return b
Just  (Node a next) -> do
b' <- f b a
foldLL' b' next

forEachLL :: (a -> IO b) -> LinkedList a -> IO ()
forEachLL f (LL first _) = forEachLL' first
where forEachLL' ref = do
case mNode of
Nothing -> return ()
Just (Node a next) -> f a >> forEachLL' next

-- Patient data type

data Patient = Patient {countdown :: IORef Int
,totalTime :: IORef Int
,visits :: IORef Int}

makePatient :: IO Patient
makePatient = liftM3 Patient (newIORef 0) (newIORef 0) (newIORef 0)

patientStay :: Patient -> Int -> IO ()
patientStay p t = do
writeIORef (countdown p) t
modifyIORef (totalTime p) (+t)

-- Stats data type

data Stats = Stats !Int !Int !Int deriving Show

(Stats p t v) +++ (Stats p' t' v') = Stats (p+p') (t+t') (v+v')

-- Joint Patient and Stats operation

addPatient :: Stats -> Patient -> IO Stats
addPatient (Stats p t v) patient = do
return (Stats (succ p) (t+t') (v+v'))

-- Hospital data type

data Hospital = Hospital {topLevel :: Bool
,random :: (IO Double)
,staff :: IORef Int
,statistics :: IORef Stats
}

makeHospital :: Int -> IO Double -> IO Hospital
makeHospital level rand = do
staff' <- newIORef (1 `shiftL` (pred level))
[triage',examination',treatment'] <- replicateM 3 newLL
statistics' <- newIORef (Stats 0 0 0)
return \$ Hospital (level==levels) rand staff' triage' examination' treatment' statistics'

-- Region data type

data Region = Region Hospital (Maybe (Array Int Region))

makeRegion :: Int -> Int -> Int -> IO Region
makeRegion level seed1 seed2 = do
localHospital <- makeHospital level =<< (prng ( seed1*seed2 ))
if level == 1 then return \$ Region localHospital Nothing
else let createSub i = liftM ((,) i) \$ makeRegion (pred level) ((4*seed1) + i + 1) seed2
in liftM ( (Region localHospital).Just.(array (0,pred districts)) ) \$ mapM createSub [0..pred districts]

-- Main Program

-- Assume links of nodes point to nothing
doStepHospital :: Hospital -> [Node Patient] -> IO [Node Patient]
doStepHospital hospital newPatients = do
out <- newIORef []
let newArrivals :: [Node Patient] -> Int -> IO ()
newArrivals [] s = writeIORef (staff hospital) s
newArrivals nps 0 = do -- no staff, triage the rest
sequence_ [ modifyIORef (visits p) succ >> addN (triage hospital) np | np@(Node p _) <- nps]
writeIORef (staff hospital) 0
newArrivals (np@(Node p _):ps) s = do -- some staff, examine patient
modifyIORef (visits p) succ
patientStay p 3
newArrivals ps \$! pred s

treatPatient :: Node Patient -> IO Bool
treatPatient (Node p _) = do
if t==1 then do addStat p
modifyIORef (staff hospital) succ
return False -- patient is cured
else do writeIORef (countdown p) (pred t)
return True -- continue treatment

addStat :: Patient -> IO ()
writeIORef (statistics hospital) s1

diagnosePatient :: Node Patient -> IO Bool
diagnosePatient np@(Node p link) = do
if t==1
then do
decide <- (random hospital)
if (decide > 0.1) || (topLevel hospital)
then do
patientStay p 10
-- staff does not change
else do
modifyIORef (staff hospital) succ
modifyIORef out (np:)
return False
else do
writeIORef (countdown p) (pred t)
return True

triagePatient :: Node Patient -> IO Bool
triagePatient np@(Node p link) = do
if s > 0
then do
writeIORef (staff hospital) (pred s)
patientStay p 3
return False
else do
modifyIORef (totalTime p) succ
return True

maybeNewPatient :: IO ()
maybeNewPatient = do
decide <- random hospital
when (decide > 0.7) \$ do
np <- liftM2 Node makePatient (newIORef Nothing)
newArrivals [np] =<< readIORef (staff hospital)
return ()

newArrivals newPatients =<< readIORef (staff hospital)
deleteAllBy treatPatient (treatment hospital)
deleteAllBy diagnosePatient (examination hospital)
deleteAllBy triagePatient (triage hospital)
maybeNewPatient

doTransferPatients :: Region -> IO [Node Patient]
doTransferPatients (Region hospital mSubs) = do
transfers <- maybe (return []) ((mapM doTransferPatients).elems) mSubs
doStepHospital hospital (concat transfers)

total :: Stats -> Region -> IO Stats
total s (Region hospital mSubs) = do
n1 <- foldLL addPatient n0 (triage hospital)
n2 <- foldLL addPatient n1 (examination hospital)
n3 <- foldLL addPatient n2 (treatment hospital)
n4 <- foldM  total      n3 (maybe [] elems mSubs)
return (s+++n4)

printQueue (Region hospital _) = do
let out ::Patient -> IO Bool
out p = do
printf "%d\tanonymous patient\n" t
return True
forEachLL out (treatment hospital)

-- Just diagnostic -- not used in benchmark
displayH :: Hospital -> IO ()
displayH hospital = do
let t = topLevel hospital
ltriage <- lengthLL (triage hospital)
lexamination <- lengthLL (examination hospital)
ltreatment <- lengthLL (treatment hospital)
print ("Hospital : "++show t)
putStrLn (unwords \$ map show [s,ltriage,lexamination,ltreatment])
print stats

main = do ns <- getArgs
let n :: Int