{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Representation of bids and bidders in LP auctions.
module ProductMixAuction.LP.Bid
  ( -- * Representation types
    Bid(..)
  , BidValue(..)

    -- * Smart constructors
  , mkEmptyBid
  , mkUnitBid
  , mkSingleBid
  , mkSymmetricBid
  , mkAsymmetricBid
  , mkGeneralisedBid
  , mkAsymmetricGeneralisedBid

    -- * Properties of bids
  , bidName
  , bidFraction
  , bidQuantityOf
  , bidDemandQuantity
  , bidValue
  , isGeneralised
  , isAsymmetric
  , showBid

    -- * Bidders
  , Bidder(..)

    -- * Lenses
  , bid_label
  , bid_name
  , bid_quantity
  , bid_values

  , bv_fraction
  , bv_quantity
  , bv_price

  , bidder_name
  , bidder_bids
  ) where

import Control.Lens
import Data.Aeson.Types as A hiding (parseField)
import Data.Default.Class
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.List
import GHC.Generics

import ProductMixAuction.Types

-- | The data stored for each good by a bid.
data BidValue =
    BidValue { _bv_fraction :: TradeOff
               -- ^ Trade-off coefficient, @a^i_j@.  For symmetric
               -- bids, this will be 1 for every good.
             , _bv_quantity :: Units
               -- ^ Maximum quantity of this good requested by the
               -- bid, @kappa^i_j@.  For non-generalised bids this
               -- will equal 'bid_quantity'.  For generalised bids this
               -- should be less than 'bid_quantity' (otherwise the
               -- constraint is irrelevant).
             , _bv_price    :: TweakedPrice
               -- ^ Price bid for the good (originally an integer but
               -- potentially tweaked when rationing).
             }
  deriving (Eq, Ord, Read, Show, Generic)

makeLenses ''BidValue

instance Default BidValue

instance FromJSON BidValue where parseJSON = genericParseJSON $ jsonOptions "_bv_"

instance ToJSON BidValue where toJSON = genericToJSON $ jsonOptions "_bv_"

-- | Represents a potentially-paired bid on an arbitrary number of
-- goods.
data Bid bid =
    Bid { _bid_label :: bid
          -- ^ A unique identifying label for this bid, @i@.
        , _bid_name  :: Maybe String
          -- ^ An optional identifying name for this bid (not necessarily unique).
        , _bid_quantity :: Units
          -- ^ The total quantity of goods requested by this bid, @k_i@.
        , _bid_values :: Map.Map Good BidValue
          -- ^ The values given to the goods by this bid,
          -- @(j, (a^i_j, kappa^i_j, v^i_j))@.
        }
  deriving (Read, Show, Generic, Functor)

makeLenses ''Bid

instance FromJSON bid => FromJSON (Bid bid) where
  parseJSON = genericParseJSON $ jsonOptions "_bid_"

instance ToJSON bid => ToJSON (Bid bid) where
  toJSON = genericToJSON $ jsonOptions "_bid_"

-- | The zero bid for no goods.
mkEmptyBid :: bid -> Bid bid
mkEmptyBid i = mkSymmetricBid i 0 []

-- | Make a bid for a single unit of a single good.
mkUnitBid :: bid -> Good -> Price -> Bid bid
mkUnitBid i g p = mkSingleBid i g p 1

-- | Make a non-paired bid, i.e. a simple bid on a single good.
mkSingleBid :: bid -> Good -> Price -> Units -> Bid bid
mkSingleBid i good p k =
  mkSymmetricBid i k [(good, p)]

-- | Make a symmetric bid on multiple goods with varying prices, but with a
-- constant number of units.
mkSymmetricBid :: bid -> Units -> [(Good, Price)] -> Bid bid
mkSymmetricBid i k xs =
  mkAsymmetricGeneralisedBid i k [ (g, (def, k, p)) | (g, p) <- xs ]

-- | Make an asymmetric bid on multiple goods, where the quantity
-- requested and the denominator of the fraction of quantity for each
-- good are specified explicitly.
mkAsymmetricBid :: bid -> Units -> [(Good, (TradeOff, Price))] -> Bid bid
mkAsymmetricBid i k xs =
  mkAsymmetricGeneralisedBid i k [ (g, (a, k, p)) | (g, (a, p)) <- xs ]

-- | Make a symmetric generalised bid, which differentiates the number
-- of units requested for each good (@kappa^i_j@) from the total
-- number of units requested (@k_i@).  Note that @kappa^i_j@ must be
-- less than or equal to @k_i@.
mkGeneralisedBid :: bid -> Units -> [(Good, (Units, Price))] -> Bid bid
mkGeneralisedBid i k xs =
  mkAsymmetricGeneralisedBid i k [ (g, (def, kappa, p)) | (g, (kappa, p)) <- xs ]

-- | Make an asymmetric, generalised bid, which differentiates the
-- number of units requested for each good (@kappa^i_j@) from the
-- total number of units requested (@k_i@).  Note that @kappa^i_j@
-- must be less than or equal to @k_i@.  The trade-off coefficient for
-- each good (@a^i_j@) must be specified explicitly.
mkAsymmetricGeneralisedBid :: bid -> Units -> [(Good, (TradeOff, Units, Price))] -> Bid bid
mkAsymmetricGeneralisedBid i k xs =
    Bid { _bid_label    = i
        , _bid_name     = Nothing
        , _bid_quantity = k
        , _bid_values   = Map.fromList [ (g, f a kappa p)
                                       | (g, (a, kappa, p)) <- xs
                                       , p > 0
                                       ]
        }
  where
    f a kappa p = BidValue { _bv_fraction = a
                           , _bv_quantity = if kappa < k then kappa else k
                           , _bv_price    = fromIntegral p
                           }

-- | Look up the denominator of the fraction of the total quantity
-- that applies to this good (i.e. a_ij).
bidFraction :: Bid bid -> Good -> TradeOff
bidFraction bid good = maybe def _bv_fraction (Map.lookup good (bid ^. bid_values))

-- | Look up the quantity of a particular good requested by a bid
-- (i.e. @kappa^i_j@).
bidQuantityOf :: Bid bid -> Good -> Units
bidQuantityOf bid good = maybe 0 _bv_quantity (Map.lookup good (bid ^. bid_values))

-- | The quantity of this good demanded by this bid, adjusted for asymmetric
-- bids, and ignoring bidding on other goods.
bidDemandQuantity :: Bid bid -> Good -> Units
bidDemandQuantity bid good = bidQuantityOf bid good / Units (_TradeOff (bidFraction bid good))

-- | Look up the price bid for a particular good (i.e. @v^i_j@).
bidValue :: Bid bid -> Good -> TweakedPrice
bidValue bid good = maybe 0 _bv_price (Map.lookup good (bid ^. bid_values))

-- | Is this a generalised paired bid? (That is, is there a good for
-- which the maximum quantity is less than the maximum quantity for
-- the entire bid?)
isGeneralised :: Bid bid -> Bool
isGeneralised bid = any ((< _bid_quantity bid) . _bv_quantity) (bid ^. bid_values)

-- | Is this an asymmetric bid? (That is, is there a good for which
-- the trade-off coefficient is not 1?)
isAsymmetric :: Bid bid -> Bool
isAsymmetric = anyOf (bid_values . each . bv_fraction) (/= def)

-- | An identifying name for this bid, which might be explicitly
-- specified or derived from the label.
bidName :: Show bid => Bid bid -> String
bidName bid = fromMaybe (show (_bid_label bid)) (_bid_name bid)

-- | Pretty-print a bid.
showBid :: Show bid => Bid bid -> String
showBid bid = show (_bid_label bid) ++ ": " ++ maybe "" ((++ ": ")) (_bid_name bid)
                ++ show (_Units (bid ^. bid_quantity)) ++ " units from "
                ++ intercalate " OR " (map showValue (Map.toList (bid ^. bid_values)))
  where
    showValue (g, bv) = show (_Units (_bv_quantity bv))
                              ++ " of " ++ show g
                              ++ " at " ++ show (_TweakedPrice (_bv_price bv))
                              ++ if a /= def then " (trade-off " ++ show a ++ ")" else ""
      where
        a = _bv_fraction bv


-- | A bidder is essentially just a collection of bids, as far as the
-- program is concerned, associated together for reasons of
-- presentation.
data Bidder bid =
    Bidder
        { _bidder_name :: BidderName -- ^ An identifying name for this bidder (necessarily unique)
        , _bidder_bids :: [Bid bid]  -- ^ Bids made by this bidder
        }
  deriving (Generic, Show)

makeLenses ''Bidder

instance FromJSON bid => FromJSON (Bidder bid) where
  parseJSON = genericParseJSON $ jsonOptions "_bidder_"

instance (ToJSON bid) => ToJSON (Bidder bid) where
  toJSON = genericToJSON $ jsonOptions "_bidder_"