Shootout/Healthcare
< Shootout
Jump to navigation
Jump to search
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/
--
-- Haskell Wiki page for Shootout entries - http://haskell.org/hawiki/ShootoutEntry
--
-- 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 Control.Monad
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
--data LinkedList a = LL !(Link a) !(IORef (Link a))
--type Link a = IORef (Maybe (Node a))
--data Node a = Node !a !(Link a)
-- Alternative is
data LinkedList a = LL !(Link a) !(IORef (Link a))
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
-- addN assume link is a IORef that holds NoNode
addN :: LinkedList a -> Node a -> IO ()
addN (LL first last) node@(Node _ link) = do
temp <- readIORef last
writeIORef temp node
writeIORef last link
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
mFirst <- readIORef ref
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
mNext <- readIORef next
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'
mFirst <- readIORef first
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
mNode <- readIORef ref
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
mNode <- readIORef ref
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
t' <- readIORef (totalTime patient)
v' <- readIORef (visits patient)
return (Stats (succ p) (t+t') (v+v'))
-- Hospital data type
data Hospital = Hospital {topLevel :: Bool
,random :: (IO Double)
,staff :: IORef Int
,triage :: LinkedList Patient
,examination :: LinkedList Patient
,treatment :: LinkedList Patient
,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
addN (triage hospital) np
) | 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
addN (examination hospital) np
newArrivals ps $! pred s
treatPatient :: Node Patient -> IO Bool
treatPatient (Node p _) = {-# SCC "treatPatient" #-} do
t <- readIORef (countdown p)
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 ()
addStat patient = {-# SCC "addStat" #-} do
s0 <- readIORef (statistics hospital)
s1 <- addPatient s0 patient
writeIORef (statistics hospital) s1
examinePatient :: Node Patient -> IO Bool
examinePatient np@(Node p link) = {-# SCC "diagnosePatient" #-} do
t <- readIORef (countdown p)
if t==now
then do
writeIORef link NoNode
decide <- (random hospital)
if (decide > 0.1) || (topLevel hospital)
then do
modifyIORef (totalTime p) (+10)
writeIORef (countdown p) (now+10)
addN (treatment hospital) np
else do
modifyIORef (staff hospital) succ
modifyIORef out (np:)
return False
else do
return True
doTriage :: IO ()
doTriage = do
s <- readIORef (staff hospital)
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
writeIORef link NoNode
addN (examination hospital) np) | np@(Node p link) <- nps]
maybeNewPatient :: IO ()
maybeNewPatient = {-# SCC "maybeNewPatient" #-} do
decide <- random hospital
when (decide > 0.7) $ do
p <- makePatient
np <- liftM (Node p) (newIORef NoNode)
s <- readIORef (staff hospital)
if s==0 then do writeIORef (countdown p) (succ now)
addN (triage hospital) np
else do writeIORef (staff hospital) (pred s)
modifyIORef (totalTime p) (+3)
writeIORef (countdown p) (now+3) -- XXX
addN (examination hospital) np
return ()
{-# SCC "do1" #-} (newArrivals newPatients =<< readIORef (staff hospital))
{-# SCC "do2" #-} deleteAllBy treatPatient (treatment hospital)
{-# SCC "do3" #-} deleteAllBy examinePatient (examination hospital)
{-# SCC "do4" #-} doTriage
maybeNewPatient
readIORef out
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)
readIORef (statistics hospital) >>=
foldLL addPatient (triage hospital) >>=
foldLL addPatient (examination hospital) >>=
foldLL addPatient (treatment 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
t <- readIORef (countdown p)
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/
--
-- Haskell Wiki page for Shootout entries - http://haskell.org/hawiki/ShootoutEntry
--
-- 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 Control.Monad
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
data LinkedList a = LL !(Link a) !(IORef (Link a))
type Link a = IORef (Maybe (Node a))
data Node a = Node !a !(Link a)
-- Alternative is
-- data LinkedList a = LL (Link a) (IORef (Link a))
-- 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
mNode <- readIORef ref
case mNode of
Nothing -> return i
Just (Node _ next) -> loop next $! succ i
-- addN assume link is a IORef that holds Nothing
addN :: LinkedList a -> Node a -> IO ()
addN (LL first last) node@(Node _ link) = do
let mNode = Just node
temp <- readIORef last
writeIORef temp mNode
writeIORef last link
deleteAllBy :: (Node a -> IO Bool) -> (LinkedList a) -> IO ()
deleteAllBy f ll@(LL first last) = do
let loop ref node@(Node _ next) = do
mNext <- readIORef next
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'
mFirst <- readIORef first
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
mNode <- readIORef ref
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
mNode <- readIORef ref
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
t' <- readIORef (totalTime patient)
v' <- readIORef (visits patient)
return (Stats (succ p) (t+t') (v+v'))
-- Hospital data type
data Hospital = Hospital {topLevel :: Bool
,random :: (IO Double)
,staff :: IORef Int
,triage :: LinkedList Patient
,examination :: LinkedList Patient
,treatment :: LinkedList Patient
,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
addN (examination hospital) np
newArrivals ps $! pred s
treatPatient :: Node Patient -> IO Bool
treatPatient (Node p _) = do
t <- readIORef (countdown p)
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 ()
addStat patient = do
s0 <- readIORef (statistics hospital)
s1 <- addPatient s0 patient
writeIORef (statistics hospital) s1
diagnosePatient :: Node Patient -> IO Bool
diagnosePatient np@(Node p link) = do
t <- readIORef (countdown p)
if t==1
then do
writeIORef link Nothing
decide <- (random hospital)
if (decide > 0.1) || (topLevel hospital)
then do
patientStay p 10
-- staff does not change
addN (treatment hospital) np
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
s <- readIORef (staff hospital)
if s > 0
then do
writeIORef (staff hospital) (pred s)
writeIORef link Nothing
patientStay p 3
addN (examination hospital) np
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
readIORef out
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
n0 <- readIORef (statistics hospital)
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
t <- readIORef (countdown p)
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
s <- readIORef (staff hospital)
ltriage <- lengthLL (triage hospital)
lexamination <- lengthLL (examination hospital)
ltreatment <- lengthLL (treatment hospital)
stats <- readIORef (statistics hospital)
print ("Hospital : "++show t)
putStrLn (unwords $ map show [s,ltriage,lexamination,ltreatment])
print stats
main = do ns <- getArgs
let n :: Int
n = if null ns then 100 else read (head ns)
region@(Region hospital _) <- makeRegion levels 0 42
replicateM_ n (doTransferPatients region)
(Stats p t v) <- total (Stats 0 0 0) region
printf "Patients: %d\nTime: %d\nVisits: %d\n" p t v
putStrLn "\nTreatment Queue - Remaining Treatment Time"
printQueue region