module ProductMixAuction.BudgetConstraints.CandidateRates where

import Control.Lens
import Data.List
import Data.Ord
import qualified Data.Set as Set
import qualified Data.Vector as V
import ProductMixAuction.BudgetConstraints.Types
import Prelude hiding (sequence)

-- * Computing candidate auction prices

-- | Calculate the set of candidate clearing rates for a list of bids using
--   an approach not yet proven correct.
candidateRates :: [Bid b] -> Set.Set PriceVector
candidateRates []           = Set.empty
candidateRates bids@(bid:_) = foldl' f Set.empty [ (interaction, sequence)
                                                 | interaction <- interactions dims bids
                                                 , sequence    <- sequences dims
                                                 ]
  where
    dims = V.length (_bid_prices bid)

    f candidates (interaction, sequence) =
      case getCandidate interaction sequence of
        Just candidate {-  | nonZeroPrices candidate -} -> Set.insert candidate candidates
        _                                               -> candidates

    -- nonZeroPrices = V.all (>0)

-- | An interaction is a list of n bids, where n is the dimension
-- (number of goods), such that the the first element is a threshold
-- bid.  The interaction determines the order to fix the candiate
-- rates.  Bids may be used more than once.
type Interaction b = [Bid b]

-- | Given a list of all the bids, produce a list of all the
-- interactions, that is, generate all the possible lists of @n@
-- bids.
interactions :: Dimension -> [Bid b] -> [Interaction b]
interactions 0 _    = []
interactions 1 bids = map return bids
interactions n bids = do bid <- bids
                         int <- interactions (n-1) bids
                         return (bid:int)

-- | A sequence is a permutation of the list of goods.
type Sequence = [Good]

-- | List all the possible sequences of goods, given the dimension.
sequences :: Dimension -> [[Good]]
sequences dims = permutations [0..dims-1]

-- | Given a particular interaction and sequence, calculate the
-- candidate price vector.  This may fail (return 'Nothing') if
-- a later bid/good in the interaction/sequence fix a price that
-- invalidates a price fixed by an earlier bid/good.
getCandidate :: Interaction b -> Sequence -> Maybe PriceVector
getCandidate bids goods = help [] [] (zip goods bids)
  where
    help :: [(Good, Price)]  -- ^ Prices we have fixed so far
         -> [(Good, Bid b)]    -- ^ Earlier bids in the interaction, kept for checking validity
         -> [(Good, Bid b)]    -- ^ Bids/goods we have not yet considered
         -> Maybe PriceVector
    help ps _old_bids []  = Just (toPriceVector ps)
    help ps old_bids  ((good, bid):xs)
      | valid     = help ((good, p') : ps) ((good,bid):rebase good p' old_bids)
                                           (rebase good p' xs)
      | otherwise = Nothing
      where
        p' = bidPrice good bid
        valid = all ((<= p') . bidPrice good . snd) old_bids

    rebase good p = map (fmap (rebaseBid good p))

-- | Make a price vector from a list of good-price pairs, provided all
-- goods from 0 to n-1 are included in the list.
toPriceVector :: [(Good, Price)] -> PriceVector
toPriceVector ps = V.fromList (map snd (sortBy (comparing fst) ps))

-- | Rebase a bid when the price for a good has been fixed.
--
-- For a threshold bid, if the bid price for the good exceeds the
-- fixed price, scale each of the other prices by the ratio of the
-- fixed price to the bid price.
rebaseBid :: Good -> Price -> Bid b -> Bid b
rebaseBid good fixed_p bid
  | bid_p > fixed_p = iover (bid_prices.imapped) r bid
  | otherwise       = bid
  where
    bid_p = bidPrice good bid

    r good' p
      | good == good' = p
      | otherwise     = p * (fixed_p / bid_p)