hw4-23.hs

{-# LANGUAGE DeriveDataTypeable #-}

module HW4_23 where

import Data.Typeable
import Data.Generics
import Math.Factorial
import Data.List
import System.IO
import Data.UUID as U
import qualified Data.UUID.V4 as U4
import Control.Monad


data CostParams = CostParams {
  _cp_arrial_rate      :: Double,
  _cp_unit_cost        :: Double,
  _cp_fixed_order_cost :: Double,
  _cp_carrying_cost    :: Double,
  _cp_lost_sales_cost  :: Double,
  _cp_lead_time        :: Double
} deriving (Show, Data, Typeable, Eq, Ord)
  

cost_par_default = CostParams {
  _cp_arrial_rate      = 1,
  _cp_unit_cost        = 6,
  _cp_fixed_order_cost = 1,
  _cp_carrying_cost    = 0.20,
  _cp_lost_sales_cost  = 25,
  _cp_lead_time        = 8
  } 

----------------------------------------                             
-- Poisson functions
pois_pdf :: Double -> Int -> Double
pois_pdf lambda k = val
  where
    fact_k = (factorial k) :: Double
    val = (exp (- lambda)) * (lambda ^^ k) / fact_k

pois_cdf :: Double -> Int -> Double
pois_cdf lambda k = sum $ map (pois_pdf lambda) [0..k]

pois_tail_cdf :: Double -> Int -> Double
pois_tail_cdf lambda k  = 1.0 - (pois_cdf lambda (k-1))
----------------------------------------


avg_annual_cost :: Int -> Int -> CostParams -> Double
avg_annual_cost q r cp = cost
  where
    tau    = (_cp_lead_time cp)
    lambda = (_cp_arrial_rate cp)
    a      = (_cp_fixed_order_cost cp)
    ic     = (_cp_carrying_cost cp)
    mu     = lambda * tau
    pi0    = (_cp_lost_sales_cost cp)
    rd     = fromIntegral r
    qd     = fromIntegral q
    that   = tau * (pois_tail_cdf  mu r) - ( rd / lambda )  * (pois_tail_cdf  mu (r+1))

    cmult  = lambda / ( qd + lambda * that)
    term1  = (1/(2 * lambda)) * qd * (qd + 1.0) + ((qd * rd)/lambda) - ((qd * mu)/lambda)

    term2  = (((ic * qd)/lambda) + pi0) * ( (mu * (pois_tail_cdf  mu (r-1))) - (rd / lambda) * (pois_tail_cdf  mu r))

    cost   = cmult  *  (a +
                        (ic * term1 ) +
                        term2
                           )

avg_annual_cost' cp q r = avg_annual_cost q r cp


----------------------------------------
indexOfMin_n n xs = map snd . take n  . Data.List.sort $ zip xs [0..]
indexOfMin xs = (indexOfMin_n 1 xs) !! 0 :: Int
----------------------------------------


weighted_cost_fn :: Int -> Int -> [(CostParams, Double)] -> Double
weighted_cost_fn q r cp_wt  = wt_cost
  where
    cost_pars = map fst cp_wt
    weights   = map snd cp_wt
    fns       = map avg_annual_cost' cost_pars
    wt_cost   = sum $ zipWith (\fn wt -> wt * (fn q r)) fns weights




print_qr_cost_tup :: [((Int, Int), Double)] -> String -> IO ()
print_qr_cost_tup tuplist fname =
  do
    let outstrs =  map (\((q,r),cost) -> show q ++ "," ++ show r ++ "," ++ show cost) tuplist
    let headerstring = "q,r,cost"
    h <- openFile fname WriteMode
    hPutStrLn h headerstring
    mapM_ (hPutStrLn h) outstrs
    hClose h


run_sim :: [(Int,Int)] -> CostParams -> [(Double,Double)] -> [Double]
run_sim qr_list cp tau_wt = costs
  where
    cp_list    = map (\(tau,_) -> cost_par_default { _cp_lead_time  = tau } ) tau_wt
    wts        = map snd tau_wt
    cp_wt      = zip cp_list wts
    costs      = map (\(q,r) -> weighted_cost_fn q r cp_wt) qr_list


-- [(Int,Int)] are the (q,r) points to evaluate
-- CostParam is the basic parameterization
-- [(Double,Double)] are [(tau_i, wt_i)]
-- fname is the output filename
run_and_stringify :: [(Int,Int)] -> CostParams -> [(Double,Double)] -> String -> [String]
run_and_stringify qr_list cp tau_w uuid = strings
  where 
    costs   = run_sim qr_list cp tau_w
    n       = length tau_w
    tau_str = concat $ intersperse "::" $map show $ map fst tau_w
    wt_str  = concat $ intersperse "::" $map show $ map snd tau_w    
    strings = map (\((q,r), cost) -> show q  ++ "," ++ show r ++ "," ++ show cost ++ "," ++ show n ++ "," ++ tau_str ++ "," ++ wt_str ++ "," ++ uuid) (zip qr_list costs)
    

run_and_print :: [(Int,Int)] -> CostParams -> [(Double,Double)] -> String -> String -> IO ()
run_and_print qr_list cp tau_w uuid fname =
  do
    let fstrings = run_and_stringify qr_list cp tau_w uuid
    print_strlist fstrings fname


print_strlist :: [String] -> String -> IO ()
print_strlist fstrings fname = do
    let headerstring = "q,r,cost,n,taulist,wtlist,uuid"
    h <- openFile fname WriteMode
    hPutStrLn h headerstring
    mapM_ (hPutStrLn h) fstrings
    hClose h

  

main :: IO()
main = do


  -- original problem
  let qr_list = [(q,r) | q <- [2..100], r <- [2..100], r < q] :: [(Int, Int)]
  let leadtime_val = [8, 15] :: [Double]
  let leadtime_den = [0.3, 0.7] :: [Double]
  let tau_wt = zip leadtime_val leadtime_den
  uuid_0  <- U4.nextRandom
  let uuid_0_s = U.toString uuid_0

  run_and_print qr_list cost_par_default tau_wt uuid_0_s "prob4-23_data_v2.csv"


  -- vary the weights over linear combinations of w0,w0
  let w0list   = takeWhile (<= 1.0) $  map (* 0.05) [0..] :: [Double]
  let den_list = map (\a -> [a, 1.0 - a]) w0list
  let tw_list  = map (zip leadtime_val) den_list

  uuids <- forM [1..(length den_list)] (\x -> do
     y <- U4.nextRandom
     return (U.toString y))

  let results = zipWith (\d u -> run_and_stringify qr_list  cost_par_default d u) tw_list uuids
  print_strlist (concat results) "p4-23-all2.csv"