Shootout/Healthcare

From HaskellWiki

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

TableOfContents

1 Description
2 Entry
- 2.1 IO Entry #2
- 2.2 IO Entry #1

1 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.

2 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.

2.1 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

2.2 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

Retrieved from "http://www.haskell.org/haskellwiki/Shootout/Healthcare"

Category: Code

Personal tools

Views

Shootout/Healthcare

From HaskellWiki

Contents

1 Description

2 Entry

2.1 IO Entry #2

2.2 IO Entry #1

Navigation

Toolbox