{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Core types for budget constrained PMA auctions
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(..))

-- * Core types

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

-- | Goods are identified by non-negative integers (with 0 being the
-- first good).
type Good = Int

-- | The number of goods must be a positive integer.
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 n good units@ creates an @n@-dimensional quantity vector
--   with zeroes everywhere except possibly in the entry for @good@,
--   which is set to @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

-- | A budget-constrained bid.  Only threshold bids are implemented so
-- far, not price-taking (non-competitive) bids.
data Bid b = Bid { _bid_label :: b
                   -- ^ A unique identifying label for this bid
                 , _bid_name  :: BidName
                   -- ^ Label of the bid for display purposes only
                 , _bid_budget :: Budget
                   -- ^ Total budget offered in bid, @q^b@
                 , _bid_prices :: PriceVector
                   -- ^ Maximum unit price on each good bidder is willing to pay, @r^b_i@
                 }
  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 ]