{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
module ProductMixAuction.BudgetConstraints where
import Control.Exception (throw)
import Control.Lens hiding (allOf)
import Control.Monad (forM, forM_, when, guard, replicateM)
import Data.Function (on)
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import qualified Data.Text as T
import Data.Tree
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Prelude hiding (sequence)
import ProductMixAuction.BudgetConstraints.CandidateRates (candidateRates)
import ProductMixAuction.BudgetConstraints.Intersect (allCandidateRates, epsilon)
import ProductMixAuction.BudgetConstraints.Types
import ProductMixAuction.Supply
import qualified ProductMixAuction.Types as Types
import ProductMixAuction.Types (Units(..))
import qualified Test.QuickCheck as QC
data BCAuction b =
BCAuction { _bca_kind :: AuctionKind
, _bca_filter_prices :: FilterPrices
, _bca_supply :: SupplyCurveVector
, _bca_bids :: [Bid b]
}
deriving Eq
instance Show (BCAuction b) where
show (BCAuction _ _ scs bids) = unlines
[ "Bids"
, "===="
, intercalate "\n" (map ppBid bids)
, ""
, "Supplies"
, "========"
, intercalate "\n" (zipWith ppSC [0..] $ V.toList scs)
]
where ppBid b = T.unpack (b^.bid_name) ++ ": budget=" ++ show (_Budget $ b^.bid_budget)
++ ", unit prices = " ++ show (map _Price . V.toList $ b^.bid_prices)
ppSC i sc = "good " ++ show (i :: Int) ++ ": "
++ intercalate ", " (map ppStep $ sc^.sc_steps)
ppStep (Step n p) = "unit price of " ++ show (Types._Price p) ++ " for "
++ show (_Units n) ++ " more units"
instance b ~ Types.B => QC.Arbitrary (BCAuction b) where
arbitrary = do
numGoods <- QC.choose (1, 3)
numBids <- QC.choose (1, 5)
BCAuction <$> QC.arbitrary <*> QC.arbitrary <*> genSupplies numGoods <*> genBids numGoods numBids
where genSupplies ngoods = V.fromList <$> replicateM ngoods genSupplyCurve
genSupplyCurve = arbitraryFiniteSupplyCurve (QC.choose (1, 3)) (fromInteger <$> QC.choose (30, 50)) (fromInteger <$> QC.choose (1, 2))
genBids ngoods nbids = forM [Types.B 1 .. Types.B nbids] (genBid ngoods)
genBid ngoods i = do
budget <- fromInteger <$> QC.choose (1, 20)
prices <- fmap V.fromList . replicateM ngoods $ (fromInteger <$> QC.choose (1, 5))
return (Bid i "_" budget prices)
shrink (BCAuction ak fp scs bids) = BCAuction ak fp scs <$> filter (not . null) (QC.shrinkList QC.shrinkNothing bids)
$(makeLenses ''BCAuction)
data BCAuctionResult b =
BCAuctionResult { _bcar_prices :: PriceVector
, _bcar_quantities :: QuantityVector
, _bcar_allocations :: BidAssignments b
, _bcar_profit :: Price
}
deriving (Eq, Show)
$(makeLenses ''BCAuctionResult)
mapBCAuctionResult :: Ord b' => (b -> b') -> BCAuctionResult b -> BCAuctionResult b'
mapBCAuctionResult f = over bcar_allocations (Map.mapKeys f)
-- * Exploring quantity space
-- | The simple objective function from the document:
-- sum over i of q_i * p_i - c_i(q_i)
--
-- where:
-- - i ranges over goods
-- - q_i is the quantity of good i sold by the auctioneer
-- - p_i is the auction price for good i
-- - c_i is the cost of providing q_i units of good i
objectiveFun :: SupplyCurveVector -> PriceVector -> QuantityVector -> Price
objectiveFun supplies pv qv = {- trace ("objectiveFun: " ++ show (map _Price $ V.toList pv)
++ " - " ++ show (map _Units $ V.toList qv)) $ -}
V.sum (V.zipWith3 profitForGood supplies pv qv)
where
profitForGood curve price qty = -- traceShow (price, qty) $
Price (_Units qty) * price - costFor qty curve
data WinningBid
= NonMarginal Good Budget
-- ^ the bid should get the given budget worth of the given
-- good, no flexibility whatsoever.
--
-- happens when a bid has a unique highest
-- (bid_price / auction price) ratio among
-- the goods that's strictly greater than 1.
| Marginal MarginalBid
-- ^ a bid that leaves a choice in the budget and/or goods it should get
deriving (Eq, Show)
-- | This type describes what kind of choice we have
-- when assigning quantities of goods to each bid, for those
-- bids that by the rules of a budget-constrained PMA, leave us
-- a choice, whether in terms of budget, goods or both.
--
-- - The 'MarginalGoods' constructor indicates that the bid has
-- offered strictly more than the auction price for at least
-- two goods. This type of bid will gets its budget worth of goods,
-- but it can get any linear combination of the goods in which
-- it is "marginal".
--
-- - The 'MarginalBudget' constructor indicates that the bid has offered
-- exactly the auction price for one or more goods and will therefore
-- get any linear combination of those goods that's worth between 0 and the
-- bid's budget.
data MarginalBid
= MarginalGoods [Good] Budget
-- ^ the bid should get any linear combination of the given
-- goods that's worth the given budget (it must use the
-- entire budget).
--
-- happens when there is a highest
-- bid_price / auction_price ratio that's strictly
-- greater than 1, but realised by several goods.
-- the list of goods is therefore guaranteed to contain
-- at least two goods, because otherwise the bid would not
-- be marginal and would just spend all its budget on the
-- unique good that realises the highest ratio.
| MarginalBudget [Good] Budget
-- ^ the bid should get anywhere between 0 and the given budget
-- worth of any linear combination of given goods.
--
-- happens when the bid_price equals the auction_price on
-- the given goods (possibly a single one).
deriving (Eq, Ord, Show)
-- | Given a 'Bid' and auction prices for the goods, determine
-- the 'Marginality' of the 'Bid'.
--
-- This functions returns 'Nothing' if the 'Bid' is not a
-- winning one, or some 'Marginality' otherwise.
marginality :: AuctionKind -> PriceVector -> Bid b -> Maybe WinningBid
marginality ak pv bid
| not winning = Nothing
| nonMarginal =
Just $ NonMarginal (winningGoods V.! 0) (bid ^. bid_budget)
| marginalGoodsStrict =
Just . Marginal $ MarginalGoods (V.toList winningGoods) (bid ^. bid_budget)
| otherwise =
Just . Marginal $ MarginalBudget (V.toList winningGoods) (bid ^. bid_budget)
where -- we set the ratio to 0 for goods for which the candidate auction price
-- is 0, so as to avoid considering any bid for those goods as winning,
-- precisely because an auction price of 0 means "nobody gets any quantity
-- of that good".
f bp ap = case ak of
Standard -> bp - ap
BudgetConstrained -> if ap < epsilon then 0 else bp / ap
ratios = V.zipWith f (bid ^. bid_prices) pv
maxRatio = V.maximum ratios
winningGoods = V.findIndices (veryVeryCloseTo maxRatio) ratios
winning = maxRatio >= winThreshold - epsilon
winThreshold = case ak of
Standard -> 0
BudgetConstrained -> 1
nonMarginal = maxRatio > winThreshold + epsilon && V.length winningGoods == 1
marginalGoodsStrict = maxRatio > winThreshold + epsilon && V.length winningGoods > 1
veryVeryCloseTo a b = abs (a - b) < epsilon
-- | Given auction prices and bids, get all the winning bids
-- along with their 'Marginality'.
computeWinningBids :: AuctionKind -> PriceVector -> [Bid b] -> [(Bid b, WinningBid)]
computeWinningBids ak pv = catMaybes . map (\b -> (b,) <$> marginality ak pv b)
-- | Given auction prices and winning bids, compute:
--
-- - the quantities that necessarily have to be sold because they are
-- demanded by 'NonMarginal' bids;
-- - all the bids that _are_ marginal (offer a choice), that will
-- power some quantity space search algorithm.
initialQuantities
:: Ord b
=> AuctionKind
-> SupplyCurveVector
-> PriceVector
-> [(Bid b, WinningBid)]
-> Maybe (QuantityVector, BidAssignments b, [([Bid b], MarginalBid)])
initialQuantities ak scs pv bids = case foldl' f (zeroVector, mempty, []) bids of
(qv, assigns, marginalBids)
| V.and (V.zipWith canProvide scs qv) -> Just (qv, assigns, mergeMarginalBids marginalBids)
| otherwise -> Nothing
where zeroVector = V.replicate (V.length pv) 0
canProvide sc q = maxQuantity (sc^.sc_steps) >= q
f (qtys, assigns, marginalBids) (bid, NonMarginal good budg) =
( V.modify (\mv -> MV.modify mv (+q) good) qtys
, assigns <> Map.fromList [(bid ^. bid_label, justGood (V.length pv) good q)]
, marginalBids
)
where q = budgetToQuantity ak budg (pv V.! good)
f (qtys, assigns, marginalBids) (bid, Marginal marg) =
( qtys
, assigns
, marginalBids ++ [(bid, marg)]
)
-- | Given a list of bids with their marginality, group together
-- bids that are marginal in the same way, calculating the total
-- budget across them all.
mergeMarginalBids :: [(Bid b, MarginalBid)] -> [([Bid b], MarginalBid)]
mergeMarginalBids = map squash . groupBy (cmp `on` snd) . sortBy (comparing snd)
where
cmp (MarginalGoods gs _) (MarginalGoods gs' _) = gs == gs'
cmp (MarginalBudget gs _) (MarginalBudget gs' _) = gs == gs'
cmp _ _ = False
squash :: [(Bid b, MarginalBid)] -> ([Bid b], MarginalBid)
squash = foldl1' combine . map (\ (b, m) -> ([b], m))
combine (bs1, m1) (bs2, m2) = (bs1 ++ bs2, combine_marginality m1 m2)
combine_marginality (MarginalGoods gs budg) (MarginalGoods _ budg') = MarginalGoods gs (budg+budg')
combine_marginality (MarginalBudget gs budg) (MarginalBudget _ budg') = MarginalBudget gs (budg+budg')
combine_marginality m1 m2 = error $ "mergeMarginalBids: combine_marginality " ++ show m1 ++ " " ++ show m2
ppAssignments :: Show b => BidAssignments b -> String
ppAssignments = intercalate "\n" . map f . Map.toList
where f (b, qv) = show b ++ " -> " ++ show qv
-- | A tree of quantities that can be sold by fulfilling
-- bid demands in different ways
type QuantityTree b = Tree (QuantityVector, BidAssignments b)
-- | Get all the leaves at the given depth in the tree.
-- Returns 'Nothing' if there are none.
treeLeaves :: Int -> Tree a -> Maybe [a]
treeLeaves n t = case treeLeaves' n t of
[] -> Nothing
ts -> Just ts
-- | Get all the leaves at the given depth in the tree.
treeLeaves' :: Int -> Tree a -> [a]
treeLeaves' n t = case drop n (Data.Tree.levels t) of
[] -> []
l:_ -> l
costFor :: Units -> SupplyCurve Units -> Price
costFor qty sc = go qty (sc^.sc_steps)
where go q []
| Just maxp <- sc^.sc_final_price = Price (_Units q) * fromIntegral maxp
| otherwise = throw (DemandTooHigh qty sc)
go q (s:ss)
| q <= s^.step_units + epsilon = Price (_Units q) * fromIntegral (s^.step_price)
| otherwise = Price (_Units $ s^.step_units) * fromIntegral (s^.step_price)
+ go (q - s^.step_units) ss
-- | Find the upper ends of the supply curve lines greater than
-- the given quantity that are within the given budget, for the
-- given price for that good.
nextStepsDiffs :: AuctionKind -> [Step Units] -> Budget -> Price -> Units -> [Maybe Units]
nextStepsDiffs ak steps budg unitPrice currUnits = diffs -- trace ("nextStepDiffs: " ++ show (map (fmap _Units) diffs)) diffs
where steps' = tail (scanl f 0 steps)
f sofar step = sofar + step^.step_units
relevantQtys = dropWhile (<=currUnits) steps'
withinBudget q =
if (q - currUnits) <= budgetToQuantity ak budg unitPrice + epsilon
then Just (q - currUnits)
else Nothing
diffs = map withinBudget relevantQtys
-- | what's the maximum quantity that the given supply curve
-- can provide?
maxQuantity :: [Step Units] -> Units
maxQuantity = foldl' (\us step -> us + step^.step_units) 0
-- | what are the next thresholds on the supply curve for the
-- given good?
nextEndpoints
:: AuctionKind
-> Budget
-> PriceVector
-> Good
-> QuantityVector
-> SupplyCurveVector
-> [Maybe Units]
nextEndpoints ak budg pv good qv supplies = case supplies V.! good of
SupplyCurve steps _ -> nextStepsDiffs ak steps budg (pv V.! good) (qv V.! good)
-- | Returns the given budget's worth of the given good, at
-- the price given by the price vector, _if there's enough
-- left_. Returns 'Nothing' otherwise.
--
-- /Note/: the case where everything is not sold yet but there isn't
-- enough to satisfy the entire given budget is already handled
-- by 'nextEndpoints'. Indeed, in such a case we would assign the remaining
-- quantity of the good to the bid and this would necessarily make us land on
-- the very last "endpoint" of the supply curve, which would in this case be
-- last `Units` value returned by 'nextEndpoints'.
allOf
:: AuctionKind
-> Budget
-> Good
-> PriceVector
-> QuantityVector
-> SupplyCurveVector
-> Maybe Units
allOf ak budget good pv qv supplies
| maxAvailable < demand = Nothing
| otherwise = {- trace ("allOf: " ++ show (_Units demand)) $ -} Just demand
where maxAvailable = maxQuantity ((supplies V.! good) ^. sc_steps) - (qv V.! good)
demand = budgetToQuantity ak budget (pv V.! good)
budgetToQuantity :: AuctionKind -> Budget -> Price -> Units
budgetToQuantity ak budget price = case ak of
Standard -> Units (_Budget budget)
BudgetConstrained -> Units (_Budget budget / _Price price)
quantityToBudget :: AuctionKind -> Units -> Price -> Budget
quantityToBudget ak qty price = case ak of
Standard -> Budget (_Units qty)
BudgetConstrained -> Budget (_Units qty * _Price price)
-- | Given supply curves for the goods, a given (auction) price vector
-- and some pre-determined quantities to be sold already for all goods,
-- look at all the potentially optimal ways to satisfy the winning bids
-- in terms of quantities of goods.
processBids
:: Ord b
=> AuctionKind
-> SupplyCurveVector
-> PriceVector
-> [([Bid b], MarginalBid)]
-> (QuantityVector, BidAssignments b)
-> [QuantityTree b]
processBids _ _supplies _pv [] (_qtys, _assigns) = []
processBids ak supplies pv ((b,m):bs) (qtys, assigns) = do
let (gs, budg, wholeBudget) = bidData m
-- we try all the possible orders in which we can assign
-- quantities to goods.
goods <- permutations gs
-- we work out all the valid quantity vectors that fulfill
-- the bid's demand, in the given order.
qtys' <- processBid ak supplies pv qtys (goods, budg, wholeBudget) []
let bidQtys = V.zipWith (-) qtys' qtys
newAssignments = assigns <> Map.fromList (distribute ak pv bidQtys gs b)
-- we build other nodes in the "quantity tree" with that given
-- quantity vector, whose children are determined by the choices of
-- quantities for subsequent bids.
let ts = processBids ak supplies pv bs (qtys', newAssignments)
return $ Node (qtys', newAssignments) ts
-- | Given a list of bids that are all marginal in the same way on the
-- given list of goods, and a quantity vector to share between them,
-- calculate the quantity assignments to individual bids. This
-- doesn't attempt to be fair between bids. Since the bids are all
-- marginal in the same way, they must have bid the same prices for
-- the goods on which they are marginal.
--
-- If the bids are marginal in the goods (but not budget), the
-- quantity vector must be sufficient to satisfy all their demands.
distribute :: AuctionKind -> PriceVector -> QuantityVector -> [Good] -> [Bid b] -> [(b, QuantityVector)]
distribute _ _ _ _ [] = []
distribute ak pv qv marginal_gs (bid:bids) = (bid ^. bid_label, qv0) : distribute ak pv qv' marginal_gs bids
where
dim = V.length pv
-- Quantity to assign to the current bid
qv0 = gives (bid ^. bid_budget) (V.replicate dim 0) marginal_gs
-- Quantity remaining to assign to subsequent bids
qv' = V.zipWith (-) qv qv0
-- Keep track of a remaining budget and an accumulated quantity
-- vector given to this bid. For a good on which the bid is
-- marginal, if the whole quantity demanded by the bid is
-- available, give it that quantity and stop. Otherwise, give it
-- the quantity of the good that is available, and continue to
-- satisfy its remaining budget using the remaining goods.
gives _ acc_qv [] = acc_qv
gives budg acc_qv (g:gs)
| desired_q <= available_q = V.zipWith (+) acc_qv (justGood dim g desired_q)
| otherwise = gives budg' (V.zipWith (+) acc_qv z) gs
where
p = pv V.! g
desired_q = budgetToQuantity ak budg p
available_q = qv V.! g
z = justGood dim g available_q
budg' = budg - quantityToBudget ak available_q p
-- | Given supply curves for the goods, an (auction) price vector and
-- the quantities of goods sold so far, find all the potentially
-- optimal (for the seller) ways to satisfy the given marginal bid's demands.
processBid
:: AuctionKind
-> SupplyCurveVector -- ^ supply curves for our goods
-> PriceVector -- ^ candidate (auction) prices for our goods
-> QuantityVector -- ^ quantities of goods sold so far in this branch
-- of the quantity space
-> ([Good], Budget, Bool) -- ^ (goods wanted by the bid, total budget, spend
-- entire budget)
-> [(Good, Units)] -- ^ accumulator that stores the quantities of goods
-- assigned to the bid so far
-> [QuantityVector] -- ^ all the possible quantities that we could sell
-- by satisfying this bid's demands in different
-- ways
processBid _ _supplies _pv qv ([], budg, spendWholeBudget) acc
| spendWholeBudget = do
guard (budg < epsilon)
return $! updateQuantities qv acc
| otherwise = do
guard (budg >= -epsilon)
return $! updateQuantities qv acc
processBid ak supplies pv qv (good:gs, budg, spendWholeBudget) acc = do -- list monad
guard (budg >= -epsilon)
Just qty <-
[ Just 0
-- don't spend anything on this good
, allOf ak budg good pv qv supplies
-- look at the quantity the bid would get for that good if it were
-- to spend its entire remaining budget on it
] ++ nextEndpoints ak budg pv good qv supplies
-- look at all the supply curve endpoints that are above the current quantity
let cost = quantityToBudget ak qty (pv V.! good)
processBid ak supplies pv qv (gs, budg - cost, spendWholeBudget) $ (good, qty) : acc
updateQuantities :: QuantityVector -> [(Good, Units)] -> QuantityVector
updateQuantities qv newQs = V.modify
(\mv -> forM_ newQs $ \(good, q) -> MV.modify mv (+q) good)
qv
-- | Summarize the marginality of a good as a list of goods,
-- a total/maximal budget and a boolean that indicates whether
-- the entire budget must be spent or whether it should just be
-- considered as an upper bound.
bidData :: MarginalBid -> ([Good], Budget, Bool)
bidData (MarginalGoods gs budg) = (gs, budg, True)
bidData (MarginalBudget gs budg) = (gs, budg, False)
-- | Return the optimal quantities to sell (for the auctioneer) as well
-- as the profit made selling those quantities.
bestQuantities
:: Ord b
=> AuctionKind
-> SupplyCurveVector
-> PriceVector
-> [Bid b]
-> Maybe (QuantityVector, BidAssignments b, Price)
bestQuantities ak supplies pv bids = {- trace ("bestQuantities: " ++ show (map _Price $ V.toList pv)) $ -} do
-- we try to satisfy all the non-marginal winning bids to determine the
-- initial state, and prepare a list of marginal bids to process later
(qtys0, assigns0, marginalBids) <- {- traceShowId $ -} initialQuantities ak supplies pv winningBids
-- we generate the quantity tree
let qtyTree = Node (qtys0, assigns0)
(permutations marginalBids >>= \bs -> processBids ak supplies pv bs (qtys0, assigns0))
-- we get our hands on all the leaves that managed to make
-- it through all the bids, assigning quantities, and ending up
-- with a valid solution. we specify the tree depth at which we're
-- expecting to find them as a safety net for now, but the
-- 'processBids' function should in theory only give us leaves at
-- the same depth. until this claim is verified, we keep the
-- explicit depth.
leaves <-
{- trace ("===\n\nTree for price vector " ++ show pv ++ "\n"
++ TV.showTree (fmap (show . fst) qtyTree)) $ -}
treeLeaves (length marginalBids) qtyTree
let (bestQty, bidAssignments) = {- trace ("qtys0: " ++ show (map _Units (V.toList qtys0))) $ -}
maximumBy (compare `on` eval.fst) leaves
{- trace ("Best one: " ++ show bestQty ++ ", profit: " ++ show (eval bestQty) {- ++ ", bids:\n" ++ ppAssignments bidAssignments -}) $ -}
return (bestQty, bidAssignments, objectiveFun supplies pv bestQty)
where winningBids = computeWinningBids ak pv bids
eval = objectiveFun supplies pv
-- * Solution to the entire problem
-- | Given the supply curves for each good and all the auction's bids,
-- return the optimal auction prices and quantities sold, in terms of
-- the auctioneer's benefits (returned as the 3rd component in the tuple).
bestPricesAndQuantities
:: Ord b
=> AuctionKind
-> ([Bid b] -> Set.Set PriceVector) -- ^ strategy for determining candidate
-- price vectors
-> SupplyCurveVector
-> [Bid b]
-> Maybe (BCAuctionResult b)
bestPricesAndQuantities ak candidatesFromBids supplies bids = {- trace "bestPricesAndQuantities" $ -} do
let pvs = V.fromList . Set.toList $ candidatesFromBids bids
when (null bids) $
throw NoBids
when (V.length pvs == 0) $
throw NoCandidatePriceVector
case V.findIndex (not . isNondecreasingSupplyCurve) supplies of
Just g -> throw (DecreasingSupplyCurve g)
Nothing -> return ()
-- we try each candidate price vector, filter out the ones that don't yield a
-- valid assignment/solution, and make sure we've got at least one candidate
-- assignment before we proceed.
let bestQtys = {- trace ("candidate prices: " ++ show (map (map _Price . V.toList) $ V.toList pvs)) $ -}
catMaybes (map bestQty $ V.toList pvs)
guard (length bestQtys > 0)
-- trace ("\nContenders:\n\n" ++ intercalate "\n\n" (map ppCandidate bestQtys)) $ return ()
let winner = maximumBy (compare `on` _bcar_profit) bestQtys
{- trace ("\n======\nWinner\n======\n\n" ++ ppCandidate winner) $ -}
return $ winner & bcar_prices %~ tweakZeroes
where bestQty pv = (\(qv, as, p) -> BCAuctionResult pv qv as p) <$> bestQuantities ak supplies pv bids
tweakZeroes = V.zipWith
(\sc p ->
if p < epsilon
then maybe 0 fromIntegral (firstReservePrice sc)
else p
) supplies
ppCandidate :: Show b => BCAuctionResult b -> String
ppCandidate (BCAuctionResult pv qv as p) = unlines
[ "auction prices: " ++ show pv
, "total quantities sold: " ++ show qv
, "seller profit: " ++ show p
] ++ "\nbid assignments:\n" ++ ppAssignments as ++ "\n"
findCandidateRates :: Eq b => AuctionKind -> FilterPrices -> [Bid b] -> Set.Set PriceVector
findCandidateRates ak fp = case ak of
Standard -> allCandidateRates Standard
BudgetConstrained -> case fp of
FilterPrices -> candidateRates
AllPrices -> allCandidateRates BudgetConstrained
runBCAuction :: Ord b => BCAuction b -> Maybe (BCAuctionResult b)
runBCAuction (BCAuction ak fp ss bs) = bestPricesAndQuantities ak (findCandidateRates ak fp) ss bs