181 lines
5.2 KiB
Haskell
181 lines
5.2 KiB
Haskell
module Holmusk where
|
||
|
||
import Data.Maybe
|
||
import System.Random
|
||
|
||
|
||
data Customer = Yellow
|
||
| Red
|
||
| Blue
|
||
deriving (Show, Eq)
|
||
|
||
|
||
e :: Double
|
||
e = exp 1
|
||
|
||
|
||
|
||
|
||
--------------------
|
||
--[ Given models ]--
|
||
--------------------
|
||
|
||
|
||
defAlpha :: Double
|
||
defAlpha = 200
|
||
|
||
|
||
-- | Probability that a customer arrives at any given time `t`.
|
||
-- Converges to `1` over time.
|
||
customerArrival :: Double -- ^ t
|
||
-> Maybe Double -- ^ 𝛼 (default: 200)
|
||
-> Double -- ^ F(t) = 1 - e^ -(t / 𝛼)
|
||
customerArrival t 𝛼 = 1.0 - (e ** (negate (t / (fromMaybe defAlpha 𝛼))))
|
||
|
||
|
||
defP :: Double
|
||
defP = 200
|
||
|
||
-- | Models the time for a customer to be processed by the teller.
|
||
customerProcTime :: Double -- ^ x
|
||
-> Maybe Double -- ^ p (default: 200)
|
||
-> Double -- ^ 𝛼
|
||
-> Double -- ^ β
|
||
-> Double -- ^ F(x) = p * x^(𝛼 - 1) * (1 - x)^(β - 1)
|
||
customerProcTime x p 𝛼 β =
|
||
(fromMaybe defP p) * (x ** (𝛼 - 1)) * ((1 - x) ** (β - 1))
|
||
|
||
|
||
|
||
|
||
--------------------------------------
|
||
--[ Average/max customer proc time ]--
|
||
--------------------------------------
|
||
|
||
|
||
-- | Get the distribution of customer processing time for x in 0.0001 to 1.0000.
|
||
customerProcTimeDist :: Customer -> [Double]
|
||
customerProcTimeDist = \case
|
||
Yellow -> fmap yellowCustomerProcTime xDist
|
||
Red -> fmap redCustomerProcTime xDist
|
||
Blue -> fmap blueCustomerProcTime xDist
|
||
where
|
||
yellowCustomerProcTime :: Double -> Double
|
||
yellowCustomerProcTime x = customerProcTime x Nothing 2.0 5
|
||
|
||
redCustomerProcTime :: Double -> Double
|
||
redCustomerProcTime x = customerProcTime x Nothing 2.0 2.0
|
||
|
||
blueCustomerProcTime :: Double -> Double
|
||
blueCustomerProcTime x = customerProcTime x Nothing 5.0 1.0
|
||
|
||
xDist :: [Double]
|
||
xDist = takeWhile (\x -> x <= 1.0) . iterate (\x -> (x + precision)) $ 0
|
||
where precision = 0.0001
|
||
|
||
|
||
-- | Average customer processing time.
|
||
avgCustomerProcTime :: Customer -> Double
|
||
avgCustomerProcTime customer =
|
||
let f = customerProcTimeDist customer
|
||
in if | length f == 0 -> 0
|
||
| otherwise -> sum f / (fromIntegral $ length f)
|
||
|
||
|
||
-- | Maximum customer processing time.
|
||
maxCustomerProcTime :: Customer -> Double
|
||
maxCustomerProcTime customer =
|
||
let f = customerProcTimeDist customer in maximum f
|
||
|
||
|
||
|
||
--------------------
|
||
--[ Queue length ]--
|
||
--------------------
|
||
|
||
|
||
-- | This correlates to `customerArrival`. Given a minimum probability x,
|
||
-- returns the time when the next customer "appears".
|
||
timeToNextCustomer :: Double -> Maybe Double -> Double
|
||
timeToNextCustomer prob 𝛼 = negate (log (1 - prob) * fromMaybe defAlpha 𝛼)
|
||
|
||
|
||
-- | The first model of a queue length. The queue length is the number
|
||
-- of people who enter the bank while the current customer is being served.
|
||
--
|
||
-- The key is the second argument `prob`. It describes the probability
|
||
-- a person appears at the bank.
|
||
queueLength :: Double -- ^ processing time of the current customer
|
||
-> Double -- ^ probability threshold when a new customer "appears"
|
||
-> Int
|
||
queueLength t' prob = go t' 0
|
||
where
|
||
go t c | t >= 0 = go (t - timeToNextCustomer prob Nothing) (c + 1)
|
||
| otherwise = c
|
||
|
||
|
||
-- | Model based on random numbers every x seconds to determine
|
||
-- whether a person appeared.
|
||
queueLengthR :: RandomGen g
|
||
=> Double -- ^ processing time of the current customer
|
||
-> Double -- ^ Interval
|
||
-> g
|
||
-> Int
|
||
queueLengthR t' int genS = go t' 0 0 (customerArrival 0 Nothing) genS
|
||
where
|
||
go :: RandomGen g
|
||
=> Double -- ^ time left til processing done
|
||
-> Double -- ^ time since last customer
|
||
-> Int -- ^ number of customers
|
||
-> Double -- ^ current probability of a customer appearing
|
||
-> g
|
||
-> Int
|
||
go tP tC c prob gen =
|
||
let (r, gen') = randomR (0.0, 1.0) gen
|
||
spawnCustomer = r < prob
|
||
in if
|
||
| tP >= 0 && spawnCustomer -> go (tP - int)
|
||
0.0
|
||
(c + 1)
|
||
(customerArrival 0.0 Nothing)
|
||
gen'
|
||
| tP >= 0 -> go (tP - int)
|
||
(tC + int)
|
||
c
|
||
(customerArrival tC Nothing)
|
||
gen'
|
||
| otherwise -> c
|
||
|
||
|
||
|
||
|
||
---------------------
|
||
--[ Waiting times ]--
|
||
---------------------
|
||
|
||
|
||
-- | The waiting times for all customers in the queue.
|
||
--
|
||
-- Whether queue length or processing time is based on the average or
|
||
-- maximum processing time is up to the caller. These could be considered
|
||
-- distinct models.
|
||
waitingTimes :: Int -- ^ queue length
|
||
-> Double -- ^ processing time
|
||
-> [Double]
|
||
waitingTimes l t =
|
||
fmap (\x -> sum (fmap (\y -> fromIntegral y * t) [x .. l])) [1 .. l]
|
||
|
||
|
||
maxWaitingTime :: Int -- ^ queue length
|
||
-> Double -- ^ processing time
|
||
-> Double
|
||
maxWaitingTime l t = maximum $ waitingTimes l t
|
||
|
||
|
||
avgWaitingTime :: Int -- ^ queue length
|
||
-> Double -- ^ processing time
|
||
-> Double
|
||
avgWaitingTime 0 t = 0
|
||
avgWaitingTime l t = (sum $ waitingTimes l t) / (fromIntegral l)
|
||
|