Skip to content

Instantly share code, notes, and snippets.

@stephenjbarr
Created March 24, 2014 20:10
Show Gist options
  • Save stephenjbarr/9748031 to your computer and use it in GitHub Desktop.
Save stephenjbarr/9748031 to your computer and use it in GitHub Desktop.
{-# 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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment