diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015-2016 Patrick Steele + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mdp.cabal b/mdp.cabal new file mode 100644 --- /dev/null +++ b/mdp.cabal @@ -0,0 +1,86 @@ +-- Initial mdp.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: mdp +version: 0.1.0.0 +synopsis: Tools for solving Markov Decision Processes. +description: + A library for formulating and solving Markov decision problems. + + We currently only solve infinite horizon problems. We handle + discounted and undiscounted problems, and can solve continuous- and + discrete-time problems. + +license: MIT +license-file: LICENSE +author: Patrick Steele +maintainer: prs233@cornell.edu + copyright: Copyright (c) 2015-2016 Patrick Steele +category: Algorithms, Math +build-type: Simple +cabal-version: >=1.8 + +-- We have to help cabal sdist find imported test files +extra-source-files: + testsuite/tests/Algorithms/MDP/Ex_3_1_Test.hs + testsuite/tests/Algorithms/MDP/Ex_3_1_RelativeTest.hs + testsuite/tests/Algorithms/MDP/Ex_3_2_Test.hs + testsuite/tests/Algorithms/MDP/Ex_MM1_Test.hs + +Library + Build-Depends: base ==4.8.* + , containers + , vector ==0.11.* + Exposed-modules: Algorithms.MDP + , Algorithms.MDP.ValueIteration, + Algorithms.MDP.CTMDP + , Algorithms.MDP.Examples.Ex_3_1 + , Algorithms.MDP.Examples.Ex_3_2 + , Algorithms.MDP.Examples.MM1 + , Algorithms.MDP.Examples + ghc-options: -Wall -fforce-recomp + hs-source-dirs: src + +executable ex-3-1 + main-is: run-ex-3-1.hs + build-depends: base ==4.8.* + , containers + , vector ==0.11.* + hs-source-dirs: src + +executable ex-3-1-relative + main-is: run-ex-3-1-relative.hs + build-depends: base ==4.8.* + , containers + , vector ==0.11.* + hs-source-dirs: src + +executable ex-3-2 + main-is: run-ex-3-2.hs + build-depends: base ==4.8.* + , containers + , vector ==0.11.* + hs-source-dirs: src + +executable mm1 + main-is: run-mm1.hs + build-depends: base ==4.8.* + , containers + , vector ==0.11.* + hs-source-dirs: src + ghc-options: -Wall + +test-suite TestMain + hs-source-dirs: testsuite/tests/, src/ + main-is: TestMain.hs + type: exitcode-stdio-1.0 + build-depends: base >= 4 && < 5 + , HTF == 0.13.* + , QuickCheck >=2.8.1 + , containers + , HUnit + , vector ==0.11.* + +source-repository head + type: git + location: https://github.com/prsteele/mdp.git diff --git a/src/Algorithms/MDP.hs b/src/Algorithms/MDP.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP.hs @@ -0,0 +1,227 @@ +-- | +-- Module : Algorithms.MDP +-- Copyright : Patrick Steele 2015 +-- License : MIT (see the LICENSE file) +-- Maintainer : prs233@cornell.edu +-- +-- Algorithms and data structures for expressing and solving Markov +-- decision processes (MDPs). +-- +-- See the following for references on the algorithms implemented, +-- along with general terminology. +-- +-- * \"Dynamic Programmand and Optimal Control, Vol. II\", by Dimitri +-- P. Bertsekas, Athena Scientific, Belmont, Massachusetts. +-- +-- * \"Stochastic Dynamic Programming and the Control of Queueing +-- Systems\", by Linn I. Sennott, A Wiley- Interscience Publication, +-- New York. +-- +-- The module "Algorithms.MDP.Examples" contains implementations of +-- several example problems from these texts. +-- +-- To actually solve an MDP, use (for example) the +-- 'Algorithms.MDP.ValueIteration.valueIteration' function from the +-- "Algorithms.MDP.ValueIteration" module. +module Algorithms.MDP + ( -- * Markov decision processes + MDP (..) + , mkDiscountedMDP + , mkUndiscountedMDP + -- * Types + , Transitions + , Costs + , ActionSet + , CF + , CFBounds (..) + -- * Utility functions + , cost + , action + , optimalityGap + -- * Validation + , verifyStochastic + , MDPError (..) + ) where + +import qualified Data.Vector as V +import Data.Maybe + +-- | A type representing an action- and state-dependent probablity +-- vector. +type Transitions a b t = b -> a -> a -> t + +-- | A type representing an action- and state-dependent cost. +type Costs a b t = b -> a -> t + +-- | A type representing the allowed actions in a state. +type ActionSet a b = a -> [b] + +-- | A cost function is a vector containing (state, action, cost) +-- triples. Each triple describes the cost of taking the action in +-- that state. +type CF a b t = V.Vector (a, b, t) + +-- | Get the cost associated with a state. +-- +-- This function is only defined over the state values passed in to +-- the original MDP. +cost :: (Eq a) => a -> CF a b t -> t +cost s cf = + let + (_, _, c) = fromMaybe err (V.find (\(s', _, _) -> s == s') cf) + err = error "Unknown state in function \"cost\"" + in + c + +-- | Get the action associated with a state. +-- +-- This function is only defined over the state values passed in to +-- the original MDP. +action :: (Eq a) => a -> CF a b t -> b +action s cf = + let + (_, ac, _) = fromMaybe err (V.find (\(s', _, _) -> s == s') cf) + err = error "Unknown state in function \"action\"" + in + ac + +-- | A cost function with error bounds. The cost in a (state, action, +-- cost) triple is guaranteed to be in the range [cost + lb, cost + ub] +data CFBounds a b t = CFBounds + { _CF :: CF a b t + , _lb :: t + , _ub :: t + } + +-- | Compute the optimality gap associated with a CFBounds. +-- +-- This error is absolute, not relative. +optimalityGap :: (Num t) => CFBounds a b t -> t +optimalityGap (CFBounds _ lb ub) = ub - lb + +-- | A Markov decision process. +-- +-- An MDP consists of a state space, an action space, state- and +-- action-dependent costs, and state- and action-dependent transition +-- probabilities. The goal is to compute a policy -- a mapping from +-- states to actions -- which minimizes the total discounted cost of +-- the problem, assuming a given discount factor in the range (0, 1]. +-- +-- Here the type variable 'a' represents the type of the states, 'b' +-- represents the type of the actions, and 't' represents the numeric +-- type used in computations. Generally choosing 't' to be a Double is +-- fine, although there is no reason a higher-precision type cannot be +-- used. +-- +-- This type should not be constructed directly; use the +-- 'mkDiscountedMDP' or 'mkUndiscountedMDP' constructors instead. +data MDP a b t = MDP + { _states :: V.Vector a + , _actions :: V.Vector b + , _costs :: V.Vector (V.Vector t) + , _trans :: V.Vector (V.Vector (V.Vector t)) + , _discount :: t + , _actionSet :: V.Vector (V.Vector Int) + } + +-- | Creates a discounted MDP. +mkDiscountedMDP :: (Eq b) => + [a] -- ^ The state space + -> [b] -- ^ The action space + -> Transitions a b t -- ^ The transition probabilities + -> Costs a b t -- ^ The action-dependent costs + -> ActionSet a b -- ^ The state-dependent actions + -> t -- ^ The discount factor + -> MDP a b t -- ^ The resulting DiscountedMDP +mkDiscountedMDP states actions trans costs actionSet discount = + let + _states = V.fromList states + _actions = V.fromList actions + mkProbAS a s = V.fromList $ map (trans a s) states + mkProbA a = V.fromList $ map (mkProbAS a) states + mkCostA a = V.fromList $ map (costs a) states + + _costs = V.fromList $ map mkCostA actions + _trans = V.fromList $ map mkProbA actions + + actionPairs = zip [0..] actions + actionSet' st = V.fromList $ map fst $ filter ((`elem` acs) . snd) actionPairs + where + acs = actionSet st + + _actionSet = V.fromList $ map actionSet' states + in + MDP + { _states = _states + , _actions = _actions + , _costs = _costs + , _trans = _trans + , _discount = discount + , _actionSet = _actionSet + } + +-- | Creates an undiscounted MDP. +mkUndiscountedMDP :: (Eq b, Num t) => + [a] -- ^ The state space + -> [b] -- ^ The action space + -> Transitions a b t -- ^ The transition probabilities + -> Costs a b t -- ^ The action-dependent costs + -> ActionSet a b -- ^ The state-dependent actions + -> MDP a b t -- ^ The resulting DiscountedMDP +mkUndiscountedMDP states actions trans costs actionSet = + mkDiscountedMDP states actions trans costs actionSet 1 + +-- | An error describing the ways an MDP can be poorly-defined. +-- +-- An MDP can be poorly defined by having negative transition +-- probabilities, or having the total probability associated with a +-- state and action exceeding one. +data MDPError a b t = MDPError + { _negativeProbability :: [(b, a, a, t)] + , _notOneProbability :: [(b, a, t)] + } + deriving (Show) + +-- | Returns the non-stochastic (action, state) pairs in an 'MDP'. +-- +-- An (action, state) pair is not stochastic if any transitions out of +-- the state occur with negative probability, or if the total +-- probability all possible transitions is not 1 (within the given +-- tolerance). + +-- | Verifies that the MDP is stochastic. +-- +-- An MDP is stochastic if all transition probabilities are +-- non-negative, and the total sum of transitions out of a state under +-- a legal action sum to one. +-- +-- We verify sums to within the given tolerance. +verifyStochastic :: (Ord t, Num t) => MDP a b t -> t -> Either (MDPError a b t) () +verifyStochastic mdp tol = + let + states = V.toList . V.indexed . _states $ mdp + actions = V.toList . V.indexed . _actions $ mdp + trans = _trans mdp + actionSet = _actionSet mdp + + nonNegTriples = [(ac, s, t, trans V.! acIndex V.! sIndex V.! tIndex) + | (acIndex, ac) <- actions + , (sIndex, s) <- states + , (tIndex, t) <- states + , acIndex `V.elem` (actionSet V.! sIndex) + , trans V.! acIndex V.! sIndex V.! tIndex < 0] + + totalProb acIndex sIndex = sum (trans V.! acIndex V.! sIndex) + badSumPairs = [(ac, s, totalProb acIndex sIndex) + | (acIndex, ac) <- actions + , (sIndex, s) <- states + , acIndex `V.elem` (actionSet V.! sIndex) + , abs (1 - totalProb acIndex sIndex) > tol + ] + in + case (null nonNegTriples, null badSumPairs) of + (True, True) -> Right () + _ -> Left MDPError + { _negativeProbability = nonNegTriples + , _notOneProbability = badSumPairs + } diff --git a/src/Algorithms/MDP/CTMDP.hs b/src/Algorithms/MDP/CTMDP.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/CTMDP.hs @@ -0,0 +1,145 @@ +-- | A continuous-time Markov decision process (CTMDP) is an MDP where +-- transitions between states take a random amount of time. Each +-- transition time is assumed to be exponentially distributed with an +-- action- and state-dependent transition rate. +-- +-- The record accessors of the 'CTMDP' type conflict with those of the +-- 'MDP' type, so either import only the 'mkCTMDP' and 'uniformize' +-- functions or import this module qualified. +module Algorithms.MDP.CTMDP + ( CTMDP (..) + , mkCTMDP + , Rates + , uniformize + ) where + +import qualified Data.Vector as V + +import Algorithms.MDP (MDP(MDP)) +import Algorithms.MDP hiding (MDP (..)) + +-- | A Continuous-time Markov decision process. +-- +-- A CTMDP is a continuous-time analog of an MDP. In a CTMDP each +-- stage takes a variable amount of time. Each stage lasts an +-- expontially distributed amount of time characterized by a state- +-- and action-dependent rate parameter. Instead of simply having costs +-- associated with a state and an action, the costs of a CTMDP are +-- broken up into fixed and rate costs. Fixed costs are incured as an +-- action are chosen, while rate costs are paid for the duration of +-- the stage. +-- +-- Here the type variable 'a' represents the type of the states, 'b' +-- represents the type of the actions, and 't' represents the numeric +-- type used in computations. Generally choosing 't' to be a Double is +-- fine, although there is no reason a higher-precision type cannot be +-- used. +-- +-- This type should not be constructed directly; use the 'mkCTMDP' +-- constructor instead. +data CTMDP a b t = CTMDP + { _states :: V.Vector a + , _actions :: V.Vector b + , _fixedCosts :: V.Vector (V.Vector t) + , _rateCosts :: V.Vector (V.Vector t) + , _rates :: V.Vector (V.Vector t) + , _trans :: V.Vector (V.Vector (V.Vector t)) + , _discount :: t + , _actionSet :: V.Vector (V.Vector Int) + } + +-- | A function mapping an action and a state to a transition rate. +type Rates a b t = b -> a -> t + +-- | Create a CTMDP. +mkCTMDP :: (Eq b) => + [a] -- ^ The state space + -> [b] -- ^ The action space + -> Transitions a b t -- ^ The transition probabilities + -> Rates a b t -- ^ The transition rates + -> Costs a b t -- ^ The action-dependent fixed costs + -> Costs a b t -- ^ The action-dependent rate costs + -> ActionSet a b -- ^ The state-dependent actions + -> t -- ^ The discount factor in (0, 1] + -> CTMDP a b t -- ^ The resulting CTMDP +mkCTMDP states actions trans rates fixedCost rateCost actionSet discount = + let + _states = V.fromList states + _actions = V.fromList actions + _states' = V.fromList [0..length states - 1] + _actions' = V.fromList [0..length actions - 1] + + mkCostVecFor cf ac = V.fromList $ map (cf ac) states + _fixedCosts = V.fromList $ map (mkCostVecFor fixedCost) actions + _rateCosts = V.fromList $ map (mkCostVecFor rateCost) actions + + mkProbAS a s = V.fromList $ map (trans a s) states + mkProbA a = V.fromList $ map (mkProbAS a) states + _trans = V.fromList $ map mkProbA actions + + mkTransVec ac = V.fromList $ map (rates ac) states + _rates = V.fromList $ map mkTransVec actions + + actionPairs = zip [0..] actions + actionSet' st = V.fromList $ map fst $ filter ((`elem` acs) . snd) actionPairs + where + acs = actionSet st + + _actionSet = V.fromList $ map actionSet' states + in + CTMDP + { _states = _states + , _actions = _actions + , _fixedCosts = _fixedCosts + , _rateCosts = _rateCosts + , _rates = _rates + , _trans = _trans + , _discount = discount + , _actionSet = _actionSet + } + +-- | Convert a CTMDP into an MDP. +uniformize :: (Ord t, Fractional t) => CTMDP a b t -> MDP a b t +uniformize ctmdc = + let + states = _states ctmdc + actions = _actions ctmdc + trans = _trans ctmdc + rateCosts = _rateCosts ctmdc + fixedCosts = _fixedCosts ctmdc + rates = _rates ctmdc + actionSet = _actionSet ctmdc + discount = _discount ctmdc + + nStates = length states + nActions = length actions + + -- The fastest transition rate + nu = maximum (fmap maximum rates) + + -- The discount factor for the continuous-time problem + beta = nu * (1 / discount - 1) + + -- We rescale the probabilities by increasing the probability of a + -- self-transition + rescaleProb ac s v = V.imap (\t z -> newP t z) v + where + newP t z = if s == t + then (nu - r + z * r) / (beta + nu) + else r * z / (beta + nu) + r = rates V.! ac V.! s + + trans' = V.imap (\a vv -> V.imap (\s v -> rescaleProb a s v) vv) trans + + -- We create costs that combine fixed and rate costs + costFor ac s = nu * ((beta + r) * f + rc) / (beta + nu) + where + f = fixedCosts V.! ac V.! s + rc = rateCosts V.! ac V.! s + r = rates V.! ac V.! s + + costs' = V.generate nActions (\ac -> V.generate nStates (costFor ac)) + + discount' = nu / (beta + nu) + in + MDP states actions costs' trans' discount' actionSet diff --git a/src/Algorithms/MDP/Examples.hs b/src/Algorithms/MDP/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/Examples.hs @@ -0,0 +1,137 @@ +{- | This module shows how to solve several example problems using this +library. +-} +module Algorithms.MDP.Examples ( + -- * A discounted problem + {- | We consider the problem defined in +"Algorithms.MDP.Examples.Ex_3_1"; this example comes from Bersekas +p. 22. + +We will solve this problem using regular value iteration. Having +constructed the MDP, we can do this using the 'valueIteration' +function. + +@ +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP.ValueIteration + +iterations :: [CF State Control Double] +iterations = valueIteration mdp +@ + +The iterates returned contain estimates of the cost of being at each +state. To see the costs of the state A over the first 10 iterations, +we could do + +@ +estimates :: [Double] +estimates = map (cost A) (take 10 iterations) +@ +-} + -- * A discounted problem with error bounds + {- | We consider the same example as above, but this time we use +relative value iteration to compute error bounds on the costs. This +will allow us to use fewer iterations to obtain an accurate cost +estimate. + +Since we have already defined the problem, we do this via the +'relativeValueIteration' function. + +@ +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP.ValueIteration + +iterations :: [CFBounds State Control Double] +iterations = relativeValueIteration mdp +@ + +The iterates returned contain estimates of the cost of being at each +state, along with associated error bounds. To see the costs of the +state A over the first 10 iterations adjusted for the error bounds, we +could do + +@ +estimate state (CFBounds cf lb ub) = (z + lb, z + ub) + where + z = cost state cf + +estimates :: [(Double, Double)] +estimates = map (estimate A) (take 10 iterations) +@ + +Note that the lower- and upper-bounds returned in the first iteration +are always +/-Infinity, and so it can be useful to consider only the +tail of the iterations. +-} + -- * An average cost problem + {- | We consider the problem defined in +"Algorithms.MDP.Examples.Ex_3_2"; this example comes from Bersekas +p. 210. + +Here we are interested in computing the long-run average cost of an +undiscounted MDP. For this we use the +'undiscountedRelativeValueIteration' function. + +@ +import Algorithms.MDP.Examples.Ex_3_2 +import Algorithms.MDP.ValueIteration + +iterations :: [CFBounds State Control Double] +iterations = undiscountedRelativeValueIteration mdp +@ + +We can compute cost estimates in the same fashion as above. + +@ +estimate state (CFBounds cf lb ub) = (lb, ub) + +estimates :: [(Double, Double)] +estimates = map (estimate A) (take 10 iterations) +@ + +It is important to note that in this problem the cost function +returned in each 'CFBounds' object is not to be interpreted as a +vector of costs, but rather as a differential cost vector; however, +the estimates above retrain the same interpretation. + +-} + -- * A continuous-time undiscounted problem + {- | We now consider a family of problems described by Sennot p. 248. + +Here we are interested in first converting a CTMDP to an MDP via +uniformization, and then computing the long-run average cost of the +optimal policy. + +To begin, we construct one of the scenarios provided (each scenario is +just an instance of the problem with certain parameters). We then +convert the scenario to an MDP using the 'uniformize' function. + +@ +import Algorithms.MDP.Examples.MM1 +import Algorithms.MDP.CTMDP +import Algorithms.MDP.ValueIteration + +scenario :: CTMDP State Action Double +scenario = mkInstance scenario1 + +mdp :: MDP State Action Double +mdp = uniformize scenario +@ + +As above, we can use the 'undiscountedRelativeValueIteration' +function to compute cost estimates. + +@ +iterations :: [CFBounds State Action Double] +iterations = undiscountedRelativeValueIteration mdp + +estimate state (CFBounds _ lb ub) = (lb, ub) + +estimates :: [(Double, Double)] +estimates = map (estimate A) (take 10 iterations) +@ +-} + ) where + +import Algorithms.MDP.ValueIteration() +import Algorithms.MDP.CTMDP() diff --git a/src/Algorithms/MDP/Examples/Ex_3_1.hs b/src/Algorithms/MDP/Examples/Ex_3_1.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/Examples/Ex_3_1.hs @@ -0,0 +1,46 @@ +-- | The problem described by Bertsekas p. 22. +module Algorithms.MDP.Examples.Ex_3_1 where + +import Algorithms.MDP + +-- | There are two distinct states +data State = A | B + deriving (Show, Ord, Eq) + +-- | There are two distinct actions we can take in each state +data Control = U1 | U2 + deriving (Show, Ord, Eq) + +-- | The transition matrix +transition :: Control -> State -> State -> Double +transition U1 A A = 3 / 4 +transition U1 A B = 1 / 4 +transition U1 B A = 3 / 4 +transition U1 B B = 1 / 4 +transition U2 A A = 1 / 4 +transition U2 A B = 3 / 4 +transition U2 B A = 1 / 4 +transition U2 B B = 3 / 4 + +-- | The costs associated with each state and action +costs :: Control -> State -> Double +costs U1 A = 2 +costs U2 A = 1 / 2 +costs U1 B = 1 +costs U2 B = 3 + +-- | The discount factor +alpha :: Double +alpha = 9 / 10 + +-- | The available states +states :: [State] +states = [A, B] + +-- | The available actions +controls :: [Control] +controls = [U1, U2] + +-- | The MDP representing the problem. +mdp :: MDP State Control Double +mdp = mkDiscountedMDP states controls transition costs (\_ -> controls) alpha diff --git a/src/Algorithms/MDP/Examples/Ex_3_2.hs b/src/Algorithms/MDP/Examples/Ex_3_2.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/Examples/Ex_3_2.hs @@ -0,0 +1,10 @@ +-- | The problem described by Bertsekas p. 210. +module Algorithms.MDP.Examples.Ex_3_2 where + +import Algorithms.MDP.Examples.Ex_3_1 hiding (mdp) + +import Algorithms.MDP + +-- | The MDP representing the problem. +mdp :: MDP State Control Double +mdp = mkUndiscountedMDP states controls transition costs (\_ -> controls) diff --git a/src/Algorithms/MDP/Examples/MM1.hs b/src/Algorithms/MDP/Examples/MM1.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/Examples/MM1.hs @@ -0,0 +1,167 @@ +-- | We model an M/M/1 queue, i.e. a single-server queue with Poisson +-- arrivals and service times. +-- +-- See "Stochastic Dynamic Programming and the Control of Queueing +-- Systems", Linn I. Sennot,, p. 242 for details. +module Algorithms.MDP.Examples.MM1 where + +import qualified Algorithms.MDP.CTMDP as CTMDP + +-- | A description of an MDP. +data Scenario = Scenario + { _arrivalRate :: Double + , _serviceRates :: [Double] + , _serviceCosts :: [Double] + , _holdingCosts :: Int -> Double + , _maxWaiting :: Int + , _scenarioCost :: Double + } + +-- | The state space is the count of customers in the queue. +newtype State = State Int + deriving (Show, Eq) + +-- | There are a number of services we can provide each customer, and +-- if there are no customers we do nothing. +data Action = NullAction + | Action Int + deriving (Show, Eq) + +-- | Generate an MDP from a Scenario. +mkInstance :: Scenario -> CTMDP.CTMDP State Action Double +mkInstance scenario = + let + -- (State i) represents i customers waiting in the queue. + states = map State [0..(_maxWaiting scenario)] + + -- (Action i) represents serving a customer with the ith service + -- profile, while the NullAction represents what we do in the + -- empty queue (wait). + actions = NullAction : map Action [0..length (_serviceRates scenario) - 1] + + -- All actions but the null action have an associated cost + rateCost (Action ac) (State i) = hc + sc + where + hc = _holdingCosts scenario i + sc = _serviceCosts scenario !! ac + rateCost NullAction _ = 0 + + -- There can always be an arrival, and if we don't take the null + -- action there can be a departure. + rates (Action ac) _ = _arrivalRate scenario + _serviceRates scenario !! ac + rates NullAction _ = _arrivalRate scenario + + -- There are no fixed costs. + fixedCost _ _= 0 + + -- We can only take the null action in state 0, and can take any + -- other action in all other states. + actionSet (State 0) = [NullAction] + actionSet _ = (tail actions) + + -- If we take the null action, we wait for an arrival. Otherwise, + -- we can increase or decrease the length of the queue by 1. + -- + -- Note that since we cannot transition about the maximum state, + -- we instead allow a self-transition. + trans NullAction (State 0) (State 1) = 1 + trans NullAction _ _ = 0 + trans (Action ac) (State i) (State j) + | j == i + 1 = lambda / (lambda + a) + | j == i && i == maxN = lambda / (lambda + a) + | j == i - 1 = a / (lambda + a) + | otherwise = 0 + where + maxN = _maxWaiting scenario + lambda = _arrivalRate scenario + a = _serviceRates scenario !! ac + in + CTMDP.mkCTMDP states actions trans rates fixedCost rateCost actionSet 1.0 + +-- | A specific scenario. +scenario1 :: Scenario +scenario1 = Scenario + { _arrivalRate = 3 + , _serviceRates = [2, 4, 8] + , _serviceCosts = [9, 13, 21] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 48 + , _scenarioCost = 8.475 + } + +-- | A specific scenario. +scenario2 :: Scenario +scenario2 = Scenario + { _arrivalRate = 2.0 + , _serviceRates = [1, 4, 7] + , _serviceCosts = [1, 50, 500] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 21.091 + } + +-- | A specific scenario. +scenario3 :: Scenario +scenario3 = Scenario + { _arrivalRate = 2.0 + , _serviceRates = [1, 4, 7] + , _serviceCosts = [1, 50, 150] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 21.091 + } + +-- | A specific scenario. +scenario4 :: Scenario +scenario4 = Scenario + { _arrivalRate = 2.0 + , _serviceRates = [1, 4, 7] + , _serviceCosts = [1, 50, 100] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 21.971 + } + +-- | A specific scenario. +scenario5 :: Scenario +scenario5 = Scenario + { _arrivalRate = 2.0 + , _serviceRates = [5.0, 5.5, 5.8] + , _serviceCosts = [0, 10, 100] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 17.043 + } + +-- | A specific scenario. +scenario6 :: Scenario +scenario6 = Scenario + { _arrivalRate = 5.0 + , _serviceRates = [5.1, 5.3, 6.0] + , _serviceCosts = [0, 10, 25] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 15.193 + } + +-- | A specific scenario. +scenario7 :: Scenario +scenario7 = Scenario + { _arrivalRate = 10.0 + , _serviceRates = [10.2, 10.6, 12] + , _serviceCosts = [0, 10, 25] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 15.193 + } + +-- | A specific scenario. +scenario8 :: Scenario +scenario8 = Scenario + { _arrivalRate = 20.0 + , _serviceRates = [24, 27, 30] + , _serviceCosts = [1, 1.5, 5.0] + , _holdingCosts = \i -> fromIntegral i + , _maxWaiting = 84 + , _scenarioCost = 3.902 + } diff --git a/src/Algorithms/MDP/ValueIteration.hs b/src/Algorithms/MDP/ValueIteration.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/MDP/ValueIteration.hs @@ -0,0 +1,169 @@ +-- | This module provides several flavors of the value iteration +-- algorithm for solving MDPs. +module Algorithms.MDP.ValueIteration + ( -- * Value iteration algorithms + valueIteration + , relativeValueIteration + , undiscountedRelativeValueIteration + -- * Helper functions for value iteration + , valueIterate + , relativeValueIterate + , undiscountedRVI + ) where + +import qualified Data.Vector as V + +import Algorithms.MDP + +-- | Compute the inner product between two vectors. +inner :: (Num t) => V.Vector t -> V.Vector t -> t +inner u v = V.sum (V.zipWith (*) u v) + +-- | Compute an infinite sequence of estimates of cost functions +-- converging to the true cost function. +-- +-- This method should only be used on discounted MDPs (e.g. an MDP +-- with a discount factor less than one). +valueIteration :: + (Ord t, Num t) => + MDP a b t -- ^ The MDP to solve + -> [CF a b t] -- ^ An converging sequence of cost functions +valueIteration mdp = + let + states = _states mdp + actions = _actions mdp + + zero = V.map (\s -> (s, V.head actions, 0)) states + in + iterate (valueIterate mdp) zero + +-- | Computes the next estimate of the cost function. +valueIterate :: (Ord t, Num t) => + MDP a b t -- ^ The MDP to solve + -> CF a b t -- ^ The current cost function estimate + -> CF a b t -- ^ The next cost function estimate +valueIterate mdp cf = V.imap (choiceFor mdp cf) (_states mdp) + +-- | Finds the action that minimizes the one-step payoff using the +-- given cost function. +choiceFor :: (Ord t, Num t) => + MDP a b t -- ^ The MDP we are solving + -> CF a b t -- ^ The current cost function + -> Int -- ^ The state for which we choose an action + -> a -- ^ The state for which we choose an action + -> (a, b, t) -- ^ The choice of action and associated cost +choiceFor mdp cf sIndex s = + let + + actions = V.fromList [(_actions mdp) V.! ac' | ac' <- V.toList ((_actionSet mdp) V.! sIndex)] + + cmp (_, x) (_, y) = compare x y + costs = V.map (costForAction mdp cf sIndex) (_actionSet mdp V.! sIndex) + pairs = V.zip actions costs + (ac, c) = V.minimumBy cmp pairs + in + (s, ac, c) + +-- | Computes the cost implied by choosing an action in the given +-- state. +costForAction :: (Num t) => + MDP a b t -- ^ The MDP we are solving. + -> CF a b t -- ^ The current cost function. + -> Int -- ^ The index of the state. + -> Int -- ^ The index of the action. + -> t -- ^ The estimated cost. +costForAction mdp cf sIndex ac = + let + alpha = _discount mdp + fixedCost = (_costs mdp) V.! ac V.! sIndex + transCost = inner (_trans mdp V.! ac V.! sIndex) (V.map (\(_, _, c) -> c) cf) + in + fixedCost + alpha * transCost + +-- | An implementation of value iteration that computes monotonic +-- error bounds. +-- +-- The error bounds provided at each iteration are additive in each +-- state. That is, given a cost estimate 'c' for a given state and +-- lower and upper bounds 'lb' and 'ub', the true cost is guaranteed +-- to be in the interval [c + lb, c + ub]. +relativeValueIteration :: + (Read t, Ord t, Fractional t) => + MDP a b t -- ^ The MDP to solve + -> [CFBounds a b t] -- ^ A converging sequence of cost functions. +relativeValueIteration mdp = + let + states = _states mdp + actions = _actions mdp + + zero = V.map (\s -> (s, V.head actions, 0)) states + + cf = CFBounds zero (read "-Infinity") (read "Infinity") + in + iterate (relativeValueIterate mdp) cf + +-- | Computes the next estimate of the cost function and associated +-- error bounds. +relativeValueIterate :: + (Ord t, Fractional t) => + MDP a b t + -> CFBounds a b t + -> CFBounds a b t +relativeValueIterate mdp (CFBounds cf _ _) = + let + alpha = _discount mdp + cf' = valueIterate mdp cf + (lb, ub) = (V.minimum diffs, V.maximum diffs) + where + diffs = V.zipWith (\(_, _, a) (_, _, b) -> a - b) cf' cf + scale = alpha / (1 - alpha) + in + CFBounds + { _CF = cf' + , _lb = scale * lb + , _ub = scale * ub + } + +-- | Relative value iteration for undiscounted MDPs. +undiscountedRelativeValueIteration :: + (Ord t, Fractional t, Read t) => + MDP a b t -- ^ The MDP to solve + -> [CFBounds a b t] -- ^ A converging sequence of cost functions +undiscountedRelativeValueIteration mdp = + let + states = _states mdp + actions = _actions mdp + + trans = _trans mdp + update s v = V.imap (\i z -> tau * z + if i == s then (1 - tau) else 0) v + + trans' = V.map (\vv -> V.imap (\s v -> update s v) vv) trans + + tau = 0.5 + mdp' = mdp {_trans = trans'} + zeroV = V.map (\s -> (s, V.head actions, 0)) states + zero = CFBounds zeroV (read "-Infinity") (read "Infinity") + distinguished = 0 + in + iterate (undiscountedRVI mdp' distinguished) zero + +-- | Performs a single iterate of relative value iteration for the +-- undiscounted problem. +undiscountedRVI :: (Ord t, Fractional t) => + MDP a b t + -> Int + -> CFBounds a b t + -> CFBounds a b t +undiscountedRVI mdp distinguished (CFBounds h _ _) = + let + th = valueIterate mdp h + (_, _, distinguishedCost) = th V.! distinguished + + th' = V.map (\(s, ac, z) -> (s, ac, z - distinguishedCost)) th + + (lb, ub) = (V.minimum diffs, V.maximum diffs) + where + diffs = V.zipWith (\(_, _, a) (_, _, b) -> a - b) th h + + in + CFBounds th' lb ub diff --git a/src/run-ex-3-1-relative.hs b/src/run-ex-3-1-relative.hs new file mode 100644 --- /dev/null +++ b/src/run-ex-3-1-relative.hs @@ -0,0 +1,23 @@ +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP +import Algorithms.MDP.ValueIteration + +import qualified Data.Vector as V + +converging :: Double + -> (CF State Control Double, CF State Control Double) + -> Bool +converging tol (cf, cf') = abs (x - y) > tol + where + x = (\(_, _, c) -> c) (cf V.! 0) + y = (\(_, _, c) -> c) (cf' V.! 0) + +iterations = relativeValueIteration mdp + +main = do + mapM_ (putStrLn . showAll) $ take 100 iterations + where + costs (CFBounds cf _ _) = V.map (\(_, _, c) -> c) cf + actions (CFBounds cf _ _) = V.map (\(_, a, _) -> a) cf + bounds (CFBounds _ lb ub) = [lb, ub] + showAll cf = unwords [show (costs cf), show (bounds cf), show (actions cf)] diff --git a/src/run-ex-3-1.hs b/src/run-ex-3-1.hs new file mode 100644 --- /dev/null +++ b/src/run-ex-3-1.hs @@ -0,0 +1,22 @@ +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP +import Algorithms.MDP.ValueIteration + +import qualified Data.Vector as V + +converging :: Double + -> (CF State Control Double, CF State Control Double) + -> Bool +converging tol (cf, cf') = abs (x - y) > tol + where + x = (\(_, _, c) -> c) (cf V.! 0) + y = (\(_, _, c) -> c) (cf' V.! 0) + +iterations = valueIteration mdp + +main = do + mapM_ (putStrLn . showAll) $ take 100 iterations + where + showCosts cf = V.map (\(_, _, c) -> c) cf + showActions cf = V.map (\(_, a, _) -> a) cf + showAll cf = show (showCosts cf) ++ " " ++ show (showActions cf) diff --git a/src/run-ex-3-2.hs b/src/run-ex-3-2.hs new file mode 100644 --- /dev/null +++ b/src/run-ex-3-2.hs @@ -0,0 +1,24 @@ +import Data.Maybe (fromJust) +import qualified Data.Vector as V + +import Algorithms.MDP.Examples.Ex_3_1 hiding (mdp, cost) +import Algorithms.MDP.Examples.Ex_3_2 +import Algorithms.MDP +import Algorithms.MDP.ValueIteration + +iterations = undiscountedRelativeValueIteration mdp +pairs = zip iterations (tail iterations) + +-- | Takes elements from a list while each adjacent pair of elements +-- satisfies the given predicate. +takeWhile2 :: (a -> a -> Bool) -> [a] -> [a] +takeWhile2 _ [] = [] +takeWhile2 p as = map fst $ takeWhile (uncurry p) (zip as (tail as)) + +distinguished = A + +showAll (CFBounds h lb ub) = unwords [show h, show lb, show ub] + +main = do + mapM_ (putStrLn . showAll) $ take 11 iterations + diff --git a/src/run-mm1.hs b/src/run-mm1.hs new file mode 100644 --- /dev/null +++ b/src/run-mm1.hs @@ -0,0 +1,60 @@ +import Text.Printf +import Control.Monad + +import Algorithms.MDP +import Algorithms.MDP.CTMDP +import Algorithms.MDP.ValueIteration +import Algorithms.MDP.Examples.MM1 + +printErrors :: MDP State Action Double -> Double -> IO () +printErrors mdp tol = case verifyStochastic mdp tol of + Left er -> do + mapM_ (putStrLn . show) (_negativeProbability er) + mapM_ (putStrLn . show) (_notOneProbability er) + Right _ -> return () + +names :: [String] +names = + [ "Scenario 1" + , "Scenario 2" + , "Scenario 3" + ] + +scenarios :: [MDP State Action Double] +scenarios = + [ uniformize (mkInstance scenario1) + , uniformize (mkInstance scenario2) + , uniformize (mkInstance scenario3) + ] + +costs :: [Double] +costs = + [ 8.475 + , 21.091 + , 21.091 + ] + +gap :: (Num t) => CFBounds a b t -> t +gap (CFBounds _ lb ub) = ub - lb + +solution :: Double -> MDP State Action Double -> CFBounds State Action Double +solution tol = + head . dropWhile ((> tol) . gap) . undiscountedRelativeValueIteration + +printSolution :: MDP State Action Double -> Double -> Double -> IO () +printSolution scenario tol c = + let + (CFBounds _ lb ub) = solution tol scenario + result = if lb <= c && c <= ub + then printf " %.3f in [%.3f, %.3f]" c lb ub + else printf " %.3f not in [%.3f, %.3f]" c lb ub + in + putStrLn result + +main :: IO () +main = do + forM_ (zip3 names scenarios costs) $ \(name, scenario, c) -> + do + putStrLn name + printErrors scenario 1e-5 + printSolution scenario 1e-3 c diff --git a/testsuite/tests/Algorithms/MDP/Ex_3_1_RelativeTest.hs b/testsuite/tests/Algorithms/MDP/Ex_3_1_RelativeTest.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Algorithms/MDP/Ex_3_1_RelativeTest.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +-- | This module tests the standard value iteration algorithm for +-- discounted problems by comparing its iterations to known iterations +-- from "Dynamic Programming and Optimal Control", Dimitri +-- P. Bertsekas, p. 23. +module Algorithms.MDP.Ex_3_1_RelativeTest where + +import Test.Framework + +import Algorithms.MDP.Ex_3_1_Test (correctValuesA, correctValuesB, almostEqual) +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP +import Algorithms.MDP.ValueIteration + +lowerValuesA :: [Double] +lowerValuesA = + [ read "-Infinity" + , 5.000 + , 6.350 + , 6.856 + , 7.129 + , 7.232 + , 7.287 + , 7.308 + , 7.319 + , 7.324 + , 7.326 + , 7.327 + , 7.327 + , 7.327 + , 7.328 + , 7.328 + ] + +upperValuesA :: [Double] +upperValuesA = + [ read "Infinity" + , 9.500 + , 8.375 + , 7.767 + , 7.540 + , 7.417 + , 7.371 + , 7.345 + , 7.336 + , 7.331 + , 7.329 + , 7.328 + , 7.328 + , 7.328 + , 7.328 + , 7.328 + ] + +lowerValuesB :: [Double] +lowerValuesB = + [ read "-Infinity" + , 5.500 + , 6.625 + , 7.232 + , 7.460 + , 7.583 + , 7.629 + , 7.654 + , 7.663 + , 7.669 + , 7.671 + , 7.672 + , 7.672 + , 7.672 + , 7.672 + , 7.672 + ] + +upperValuesB :: [Double] +upperValuesB = + [ read "Infinity" + , 10.000 + , 8.650 + , 8.144 + , 7.870 + , 7.768 + , 7.712 + , 7.692 + , 7.680 + , 7.676 + , 7.674 + , 7.673 + , 7.673 + , 7.673 + , 7.672 + , 7.672 + ] + +iterations = take 16 (relativeValueIteration mdp) + +lower s (CFBounds cf lb _) = lb + cost s cf +upper s (CFBounds cf _ ub) = ub + cost s cf + +actualValuesA = map (cost A . _CF) iterations +actualValuesB = map (cost B . _CF) iterations + +actualLowerA = map (lower A) iterations +actualUpperA = map (upper A) iterations +actualLowerB = map (lower B) iterations +actualUpperB = map (upper B) iterations + +badActualA = filter (not . almostEqual 1e-3) $ zip actualValuesA correctValuesA +badActualB = filter (not . almostEqual 1e-3) $ zip actualValuesB correctValuesB + +badLBA = filter (not . almostEqual 1e-3) $ zip actualLowerA lowerValuesA +badUBA = filter (not . almostEqual 1e-3) $ zip actualUpperA upperValuesA +badLBB = filter (not . almostEqual 1e-3) $ zip actualLowerB lowerValuesB +badUBB = filter (not . almostEqual 1e-3) $ zip actualUpperB upperValuesB + +test_AValues = assertBoolVerbose (unlines (map show badActualA)) (null badActualA) +test_BValues = assertBoolVerbose (unlines (map show badActualB)) (null badActualB) +test_LBA = assertBoolVerbose (unlines (map show badLBA)) (null badLBA) +test_UBA = assertBoolVerbose (unlines (map show badUBA)) (null badUBA) +test_LBB = assertBoolVerbose (unlines (map show badLBB)) (null badLBB) +test_UBB = assertBoolVerbose (unlines (map show badUBB)) (null badUBB) + diff --git a/testsuite/tests/Algorithms/MDP/Ex_3_1_Test.hs b/testsuite/tests/Algorithms/MDP/Ex_3_1_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Algorithms/MDP/Ex_3_1_Test.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +-- | This module tests the standard value iteration algorithm for +-- discounted problems by comparing its iterations to known iterations +-- from "Dynamic Programming and Optimal Control", Dimitri +-- P. Bertsekas, p. 23. +module Algorithms.MDP.Ex_3_1_Test where + +import Test.Framework + +import Algorithms.MDP.Examples.Ex_3_1 +import Algorithms.MDP +import Algorithms.MDP.ValueIteration + +almostEqual eps (x, y) | x == y = True + | otherwise = abs (x - y) <= eps + +iterations = take 16 (valueIteration mdp) + +correctValuesA = + [ 0 + , 0.5 + , 1.287 + , 1.844 + , 2.414 + , 2.896 + , 3.343 + , 3.740 + , 4.099 + , 4.422 + , 4.713 + , 4.974 + , 5.209 + , 5.421 + , 5.612 + , 5.783 + ] + +correctValuesB = + [ 0 + , 1 + , 1.562 + , 2.220 + , 2.745 + , 3.247 + , 3.686 + , 4.086 + , 4.444 + , 4.767 + , 5.057 + , 5.319 + , 5.554 + , 5.766 + , 5.957 + , 6.128 + ] + +actualValuesA = map (cost A) iterations +actualValuesB = map (cost B) iterations + +pairsA = zip actualValuesA correctValuesA +pairsB = zip actualValuesB correctValuesB + +badPairsA = filter (not . almostEqual 1e-3) pairsA +badPairsB = filter (not . almostEqual 1e-3) pairsB + +test_AValues = assertBoolVerbose (unlines (map show badPairsA)) (null badPairsA) +test_BValues = assertBoolVerbose (unlines (map show badPairsB)) (null badPairsB) diff --git a/testsuite/tests/Algorithms/MDP/Ex_3_2_Test.hs b/testsuite/tests/Algorithms/MDP/Ex_3_2_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Algorithms/MDP/Ex_3_2_Test.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +-- | This module tests the undiscountedRelativeValueIteration function +-- for undiscounted problems by comparing its tierations to known +-- iteratinos from "Dynamic Programming and Optimal Control", Dimitri +-- P. Bertsekas, p. 210. +-- +-- We actually implement a slightly different technique to solve this +-- problem than is reported in Bertsekas; however, our solutions +-- should converge to the same value. Thus we simply ensure that the +-- error bounds we report properly contain the solution reported by +-- Bertsekas. +module Algorithms.MDP.Ex_3_2_Test where + +import Test.Framework + +import Algorithms.MDP +import Algorithms.MDP.ValueIteration +import Algorithms.MDP.Examples.Ex_3_2 + +value = 0.750 + +iterations = take 11 (undiscountedRelativeValueIteration mdp) + +estimate (CFBounds _ lb ub) = (lb, ub) + +proper (lb, ub) = lb <= value && value <= ub + +badPairs = filter (not . proper) (map estimate iterations) + +test_values = assertBoolVerbose (unlines (map show badPairs)) (null badPairs) diff --git a/testsuite/tests/Algorithms/MDP/Ex_MM1_Test.hs b/testsuite/tests/Algorithms/MDP/Ex_MM1_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Algorithms/MDP/Ex_MM1_Test.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +-- | Tests for the problems discussed in section 10.4 of "Stochastic +-- Dynamic Programming and the Control of Queueing Systems", Linn +-- Sennot. +module Algorithms.MDP.Ex_MM1_Test where + +import Test.Framework + +import Algorithms.MDP +import Algorithms.MDP.CTMDP +import Algorithms.MDP.ValueIteration +import Algorithms.MDP.Examples.MM1 + +costOf (CFBounds _ lb ub) = (lb + ub) / 2 + +gap :: (Num t) => CFBounds a b t -> t +gap (CFBounds _ lb ub) = ub - lb + +solution :: Double -> MDP State Action Double -> CFBounds State Action Double +solution tol = + head . dropWhile ((> tol) . gap) . undiscountedRelativeValueIteration + +test_scenario1Cost = assertBoolVerbose msg (abs (c - cc) < 1e3) + where + ctmdp = uniformize (mkInstance scenario1) + sol = solution (1e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario1 + msg = unwords [show c, "/=", show cc] + +test_scenario2Cost = assertBoolVerbose msg (abs (c - cc) < 2e3) + where + ctmdp = uniformize (mkInstance scenario2) + sol = solution (2e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario2 + msg = unwords [show c, "/=", show cc] + +test_scenario3Cost = assertBoolVerbose msg (abs (c - cc) < 3e3) + where + ctmdp = uniformize (mkInstance scenario3) + sol = solution (3e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario3 + msg = unwords [show c, "/=", show cc] + +test_scenario4Cost = assertBoolVerbose msg (abs (c - cc) < 4e3) + where + ctmdp = uniformize (mkInstance scenario4) + sol = solution (4e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario4 + msg = unwords [show c, "/=", show cc] + +test_scenario5Cost = assertBoolVerbose msg (abs (c - cc) < 5e3) + where + ctmdp = uniformize (mkInstance scenario5) + sol = solution (5e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario5 + msg = unwords [show c, "/=", show cc] + +test_scenario6Cost = assertBoolVerbose msg (abs (c - cc) < 6e3) + where + ctmdp = uniformize (mkInstance scenario6) + sol = solution (6e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario6 + msg = unwords [show c, "/=", show cc] + +test_scenario7Cost = assertBoolVerbose msg (abs (c - cc) < 7e3) + where + ctmdp = uniformize (mkInstance scenario7) + sol = solution (7e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario7 + msg = unwords [show c, "/=", show cc] + +test_scenario8Cost = assertBoolVerbose msg (abs (c - cc) < 8e3) + where + ctmdp = uniformize (mkInstance scenario8) + sol = solution (8e-4) ctmdp + c = costOf sol + cc = _scenarioCost scenario8 + msg = unwords [show c, "/=", show cc] diff --git a/testsuite/tests/TestMain.hs b/testsuite/tests/TestMain.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/TestMain.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +module Main where + +import Test.Framework + +import {-@ HTF_TESTS @-} Algorithms.MDP.Ex_3_1_Test +import {-@ HTF_TESTS @-} Algorithms.MDP.Ex_3_1_RelativeTest +import {-@ HTF_TESTS @-} Algorithms.MDP.Ex_3_2_Test +import {-@ HTF_TESTS @-} Algorithms.MDP.Ex_MM1_Test + +main = htfMain htf_importedTests