Initial commit

lib/Holmusk.hs

@@ -0,0 +1,180 @@
+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)
+