{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module ProductMixAuction.BudgetConstraints.Types where
import Control.DeepSeq
import Control.Exception
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.Csv hiding ((.=))
import Data.Default.Class
import Data.Map (Map)
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics
import System.Random
import qualified Test.QuickCheck as QC
import ProductMixAuction.Supply
import ProductMixAuction.Types (jsonOptions, Units(..))
data AuctionKind = Standard | BudgetConstrained
deriving (Bounded, Enum, Eq, Generic, Show)
instance Default AuctionKind where
def = BudgetConstrained
instance ToJSON AuctionKind where
toJSON = genericToJSON $ jsonOptions ""
instance FromJSON AuctionKind where
parseJSON = genericParseJSON $ jsonOptions ""
instance QC.Arbitrary AuctionKind where
arbitrary = QC.arbitraryBoundedEnum
data FilterPrices = AllPrices | FilterPrices
deriving (Bounded, Enum, Eq, Generic, Show)
instance QC.Arbitrary FilterPrices where
arbitrary = QC.arbitraryBoundedEnum
type Good = Int
type Dimension = Int
newtype Price = Price { _Price :: Double }
deriving ( Eq, Ord, Show, FromField, ToField, Random
, Num, Fractional, Floating, Real, RealFloat, RealFrac
, Generic, NFData, QC.Arbitrary, ToJSON, FromJSON
)
instance Default Price
type PriceVector = V.Vector Price
type QuantityVector = V.Vector Units
justGood :: Int -> Good -> Units -> QuantityVector
justGood n good units = V.generate n (\k -> if k == good then units else 0)
type BidName = T.Text
newtype Budget = Budget { _Budget :: Double }
deriving ( Eq, Floating, Fractional, FromField, FromJSON, Generic
, Num, Ord, Real, RealFloat, RealFrac, Show, ToField, ToJSON
)
instance Default Budget where
def = Budget 1
data Bid b = Bid { _bid_label :: b
, _bid_name :: BidName
, _bid_budget :: Budget
, _bid_prices :: PriceVector
}
deriving (Eq, Show)
$(makeLenses ''Bid)
-- | Get the price offered for a good by a bid.
bidPrice :: Good -> Bid b -> Price
bidPrice good bid = _bid_prices bid V.! good
-- | Assignment of good quantities to bids
type BidAssignments b = Map b QuantityVector
-- | A supply curve per good
type SupplyCurveVector = V.Vector (SupplyCurve Units)
-- | Exception that the solver may throw
data BCException
= DemandTooHigh Units (SupplyCurve Units)
-- ^ when the solver tries to get the cost
-- of supplying a given quantity of some good
-- but the said quantity exceeds the supply
-- curve's capacity (this is in principle
-- ruled out by the code, but an exception is
-- a good way to signal that this impossible
-- case can in fact happen)
| NoBids
-- ^ when the solver is run on an auction with no bid
| NoCandidatePriceVector
-- ^ when the solver cannot find a single candidate
-- price vector to use for exploring different
-- allocations of quantities
| DecreasingSupplyCurve Good
-- ^ when the solver is run on an auction with a decreasing supply
-- curve for the given good
deriving Show
instance Exception BCException where
displayException NoBids
= "No (valid) bids were given"
displayException NoCandidatePriceVector
= "No valid candidate price vectors found"
displayException (DemandTooHigh qty sc)
= "Asking too much (" <> show (_Units qty) <> " units) of supply curve " <> show sc
displayException (DecreasingSupplyCurve good)
= "Supply curve for good " <> show (good+1) <> " is decreasing"
instance ToJSON BCException where
toJSON e = object [ "message" .= displayException e ]