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

-- | Search for a solution to a 'TQSS' by running the LP multiple times
-- for different sizes of auction, and comparing the resulting demand
-- prices to the TQSS function.
module ProductMixAuction.LP.TQSS
  ( -- * TQSS representation
    TQSS(..)
  , TQSSType(..)
  , AbsoluteTQSS(..)
  , TQSSPriceMeasure(..)
  , TQSSScale(..)
  , TQSSFun
  , TQSSTable
  , TQSSStep

    -- * Search strategies
  , TQSSSearchMode(..)
  , TQSSSearchStrategy

    -- * Solving the TQSS
  , TQSSPoint(..)
  , runTQSS
  , runNormalisedTQSS
  , runAbsoluteTQSS

    -- * Utilities
  , interpolateTQSS
  , isNondecreasingTQSSTable
  , isConstrainedTQSS
  , tqssTypeLabel

    -- * Lenses
  , tqss_fun
  , tqss_type
  , atqss_price_measure
  , atqss_search
  , atqss_scale
  , atqss_min_bound
  , atqss_max_bound
  , atqss_step_size

  , tqp_demand_target
  , tqp_demand
  , tqp_price
  , tqp_supply
  ) where

import Control.Applicative
import Control.Exception (throwIO)
import Control.Lens hiding ((.=))
import Control.Monad
import Data.Aeson.Types
import Data.Default.Class
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Ord
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Generics (Generic)
import qualified Test.QuickCheck as QC

import ProductMixAuction.LP.Core
import ProductMixAuction.Supply
import ProductMixAuction.Types

-- | Choice of measure used to convert the vector of prices (one for
-- each good) into a single price on which the TQSS is defined.
data TQSSPriceMeasure
  = SingleGoodPrice Good
    -- ^ Define the TQSS on the price of a single good.
  | MeanPrice
    -- ^ Define the TQSS on the mean price of all the goods.
  deriving (Eq, Generic, Show)

instance Default TQSSPriceMeasure where
    def = MeanPrice

instance ToJSON   TQSSPriceMeasure where
    toJSON = genericToJSON $ jsonOptions ""
instance FromJSON TQSSPriceMeasure where
    parseJSON = genericParseJSON $ jsonOptions ""


-- | How to change the total quantity available in the auction when
-- solving a TQSS.
data TQSSScale
  = ScaleSupply SupplyScaleLambda
    -- ^ Scale the supply curves using the given parameter @lambda@.
  | AddConstraint
    -- ^ Do not change the supply curves, but add a constraint to the
    -- LP bounding the total quantity supplied.
  deriving (Eq, Generic, Show)

instance Default TQSSScale where
    def = AddConstraint

instance ToJSON   TQSSScale where
    toJSON = genericToJSON $ jsonOptions ""
instance FromJSON TQSSScale where
    parseJSON = genericParseJSON $ jsonOptions ""


-- | Representation of a TQSS function as a Haskell function from the
-- price measure to the number of units.
type TQSSFun = Double -> Units

-- | Representation of a TQSS function as a list of steps.
type TQSSTable = [TQSSStep]

-- | Single step in a TQSS step function.
type TQSSStep = Step Units


-- | Choice of strategy used to search for the intersection
-- between the TQSS and the demand curve.
data TQSSSearchMode =
    BinarySearch
    -- ^ Find a solution to the TQSS by binary search on the interval.
    -- This minimises the number of LP iterations, but does not
    -- guarantee which solution will be returned if multiple solutions
    -- exist.
  | LinearSearchAll
    -- ^ Evaluate the TQSS at all points in the interval (separated by
    -- the step size) and choose the point at which supply and demand
    -- are closest.
  | LinearSearchBelow
    -- ^ Find a solution to the TQSS by linear search on the interval,
    -- moving in increments of the step size from the lower bound, and
    -- stopping if the upper bound is reached before the demand curve
    -- meets the TQSS.
  | CombinedSearch
    -- ^ Like 'LinearSearchAll', but additionally uses binary search
    -- to deliver a more precise result.
  deriving (Eq, Generic, Show)

instance Default  TQSSSearchMode where def = CombinedSearch
instance ToJSON   TQSSSearchMode where toJSON = genericToJSON $ jsonOptions ""
instance FromJSON TQSSSearchMode where parseJSON = genericParseJSON   $ jsonOptions ""


-- | A Total Quantity Supply Schedule (TQSS) is a function from prices to the
-- total number of units that should be made available at those
-- prices.  It must be weakly increasing (i.e. increasing any price
-- must not decrease the TQSS).
--
-- This type represents a TQSS along with options to control how the
-- search for the solution should take place.
--
-- The first parameter determines how the function on the price
-- measure is represented; it will typically be 'TQSSFun' or
-- 'TQSSTable'.
data TQSS fun = TQSS { _tqss_fun  :: fun
                       -- ^ Function giving total quantity to be supplied at given prices
                     , _tqss_type :: TQSSType
                     }
  deriving (Eq, Generic, Show)

data TQSSType = TQSSAbsolute AbsoluteTQSS | TQSSNormalised
  deriving (Eq, Generic, Show)

data AbsoluteTQSS =
    AbsoluteTQSS { _atqss_price_measure :: TQSSPriceMeasure
                   -- ^ Measure on prices using which TQSS is defined
                 , _atqss_search :: TQSSSearchMode
                   -- ^ Search algorithm for finding the intersection
                 , _atqss_scale  :: TQSSScale
                   -- ^ How to rescale the supply as the total quantity
                   -- changes
                 , _atqss_min_bound :: Maybe Units
                   -- ^ Minimum bound for the search.
                 , _atqss_max_bound :: Maybe Units
                   -- ^ Maximum bound for the search.
                 , _atqss_step_size :: Maybe Units
                   -- ^ The step size for search modes other than
                   -- 'BinarySearch'.
                 }
  deriving (Eq, Generic, Show)

makeLenses ''TQSS
makePrisms ''TQSSType
makeLenses ''AbsoluteTQSS

instance Default tqss => Default (TQSS tqss)

instance Default TQSSType where
  def = TQSSNormalised

instance ToJSON tqss => ToJSON (TQSS tqss) where
  toJSON = genericToJSON $ jsonOptions "_tqss_"

instance FromJSON tqss => FromJSON (TQSS tqss) where
  parseJSON = genericParseJSON $ jsonOptions "_tqss_"

instance ToJSON TQSSType where
  toJSON = genericToJSON $ jsonOptions ""

instance FromJSON TQSSType where
  parseJSON = genericParseJSON $ jsonOptions ""

instance ToJSON AbsoluteTQSS where
  toJSON = genericToJSON $ jsonOptions "_atqss_"

instance FromJSON AbsoluteTQSS where
  parseJSON = genericParseJSON $ jsonOptions "_atqss_"


-- | Test that the TQSS function is non-decreasing.
isNondecreasingTQSSTable :: TQSSTable -> Bool
isNondecreasingTQSSTable = go 0
  where
    go _ [] = True
    go p (s:ss) = s^.step_price >= p && go (s^.step_price) ss

-- | Does this TQSS work by constraining the total quantity supplied?
isConstrainedTQSS :: TQSS fun -> Bool
isConstrainedTQSS tqss = case tqss ^. tqss_type of
    TQSSNormalised     -> True
    TQSSAbsolute atqss -> case atqss ^. atqss_scale of
                            AddConstraint{} -> True
                            ScaleSupply{}   -> False


-- | A TQSS search strategy is given the lower and upper bounds for the total
-- size, a description of the TQSS and a scaled auction.  It returns a
-- list of points at which the TQSS was evaluated; the solution is the
-- point at which demand is closest to supply.
type TQSSSearchStrategy = forall bid . Goodly bid
                       => TQSSFun
                       -> AbsoluteTQSS
                       -> Maybe [Step Units]
                       -> Auction bid
                       -> IO [TQSSPoint]

-- | A point at which the TQSS has been evaluated.
data TQSSPoint =
    TQSSPoint { _tqp_demand_target :: Units
               -- ^ The total size of the auction that was selected.
              , _tqp_demand :: Units
                -- ^ The total size of the auction (i.e. the "demand")
                -- that was evaluated (this may differ from
                -- '_tqp_demand_target' because when rescaling the
                -- supply curves we may change the total).
              , _tqp_price  :: Double
                -- ^ The price measure resulting from solving the
                -- auction at the demand size.
              , _tqp_supply :: Units
                -- ^ The desired supply given by evaluating the TQSS
                -- function at the price measure.
              }
  deriving (Eq, Show, Generic)

makeLenses ''TQSSPoint

instance Default  TQSSPoint
instance ToJSON   TQSSPoint where toJSON = genericToJSON $ jsonOptions "_tqp_"
instance FromJSON TQSSPoint where parseJSON = genericParseJSON $ jsonOptions "_tqp_"

instance QC.Arbitrary TQSSPoint where
  arbitrary = TQSSPoint <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary



-- | Evaluate a TQSS price measure as a function from the prices of
-- all the goods to a single price.
evalPriceMeasure :: TQSSPriceMeasure -> Map.Map Good Price -> Double
evalPriceMeasure (SingleGoodPrice good) ps = maybe 0 fromIntegral (Map.lookup good ps)
evalPriceMeasure MeanPrice              ps = fromIntegral (sum (Map.elems ps)) / fromIntegral (Map.size ps)

-- | Evaluate the TQSS at the given prices, producing both the price
-- measure and the desired number of units to supply.
evalTQSS :: TQSSFun -> AbsoluteTQSS -> AuctionResult bid -> (Double, Units)
evalTQSS fun atqss ar = (p, fun p)
  where
    pm  = atqss ^. atqss_price_measure
    p   = evalPriceMeasure pm ps
    ps  = ar ^. ar_prices


-- | Find a solution to the TQSS by binary search on the interval.
-- This minimises the number of LP iterations, but does not guarantee
-- which solution will be returned if multiple solutions exist.
--
-- The search will terminate if the distance between points will be
-- eliminated by rounding to the scale of the auction.
binarySearch :: TQSSSearchStrategy
binarySearch fun atqss _ auction = help [] (tqssMinBound atqss auction) (tqssMaxBound atqss auction)
  where
    help accum lo hi = do
        let x = (lo + hi) / 2
        tqp <- evaluate fun atqss auction x
        let accum' = tqp : accum
        case compare (_tqp_supply tqp) x of
          _ | hi - lo < epsilon -> return (reverse accum')
          EQ                    -> return (reverse accum')
          LT                    -> help accum' lo x
          GT                    -> help accum' x hi

    epsilon = Units (scaleDistance (auction ^. auction_scale) / 2)

-- | Find a solution to the TQSS by linear search on the interval,
-- moving in increments of the step size from the lower bound, and
-- stopping if the upper bound is reached before the demand curve
-- meets the TQSS.
linearSearchBelow :: TQSSSearchStrategy
linearSearchBelow fun atqss _ auction = help [] start
  where
    start = tqssMinBound atqss auction
    stop  = tqssMaxBound atqss auction
    step  = tqssStepSize atqss auction

    help accum x | x >= stop = return (reverse accum)
                 | otherwise = do tqp <- evaluate fun atqss auction x
                                  let accum' = tqp : accum
                                  case compare (_tqp_supply tqp) x of
                                    EQ -> return (reverse accum')
                                    LT -> return (reverse accum')
                                    GT -> help accum' (x+step)

-- | Evaluate the TQSS at evenly spaced points in the interval between
-- start and stop (separated by the step size) and choose the point at
-- which supply and demand are closest.  If the steps of the TQSS are
-- known, step endpoints will also be searched.
linearSearchAll :: TQSSSearchStrategy
linearSearchAll fun atqss mb_steps auction =
    mapM (evaluate fun atqss auction) rs'
  where
    start = tqssMinBound atqss auction
    stop  = tqssMaxBound atqss auction
    step  = tqssStepSize atqss auction

    rs | step > 0, stop > start = [start,start+step..stop]
       | otherwise              = [start]
    rs' = maybe rs (Set.toList . Set.union (Set.fromList rs) . Set.fromList . filter okay . stepPoints) mb_steps
    okay p = p > start && p < stop

-- | Convert the widths of the steps into a list of quantity
-- values at which the TQSS step function changes.
stepPoints :: [Step Units] -> [Units]
stepPoints = go 0
  where
    go _ []           = []
    go u (step:steps) = u' : go u' steps
      where
        u' = u + step ^. step_units

-- | Evaluate the TQSS at fixed points in the interval as with
-- 'linearSearchAll'.  If this yields a solution, stop.  Otherwise,
-- find a smaller interval in which a solution exists and perform
-- binary search on that interval.
--
-- This offers a reasonable balance between speed, precision, and
-- clarity when the points are plotted as a graph.  It does not
-- guarantee which solution will be returned if multiple solutions
-- exist.
--
-- The required precision from the result can be specified, or if it
-- is omitted, the search will terminate if the distance between
-- points will be eliminated by rounding to the scale of the auction.
combinedSearch :: TQSSSearchStrategy
combinedSearch fun atqss mb_steps auction = do
    ps <- linearSearchAll fun atqss mb_steps auction
    case findIntersectionInterval ps of
      Left _            -> return ps
      Right (tqp, tqp') -> let atqss' = atqss & atqss_min_bound ?~ _tqp_demand tqp
                                              & atqss_max_bound ?~ _tqp_demand tqp'
                           in (ps ++) <$> binarySearch fun atqss' mb_steps auction

evalTQSSSearch :: TQSSSearchMode -> TQSSSearchStrategy
evalTQSSSearch k =
  case k of
    BinarySearch      -> binarySearch
    LinearSearchAll   -> linearSearchAll
    LinearSearchBelow -> linearSearchBelow
    CombinedSearch    -> combinedSearch


-- | Evaluate the TQSS at the given demand auction size, calculating
-- the price measure and desired supply size at that price.
evaluate :: Goodly bid
         => TQSSFun -> AbsoluteTQSS -> Auction bid -> Units
         -> IO TQSSPoint
evaluate fun atqss auction0 r = do
    ar <- runAuctionCore "tqss" auction
    let (price, units) = evalTQSS fun atqss ar
        point = TQSSPoint { _tqp_demand_target = r
                          , _tqp_demand        = r'
                          , _tqp_price         = price
                          , _tqp_supply        = units
                          }
    debugPrint v "evaluate: point" point
    debugPrint v "evaluate: result" ar
    return point
  where
    (auction, r') = scaleAuction (atqss ^. atqss_scale) auction0 r
    v = auction ^. auction_verbosity

-- | Convert a TQSS function represented as a list of steps into a
-- proper Haskell function.  If a maximum bound for the TQSS search is
-- not set, use the upper limit of the domain of the step function.
interpolateTQSS :: TQSS TQSSTable -> TQSS TQSSFun
interpolateTQSS tqss =
    tqss & tqss_fun .~ interpolate 0 xs
         & tqss_type._TQSSAbsolute.atqss_max_bound %~ (<|> Just m)
  where
    (m, xs) = unTQSSSteps 0 (tqss ^. tqss_fun)

    -- Accumulate the total step width so far, to produce a list of
    -- points with absolute rather than relative coordinates.  Return
    -- the largest coordinate.
    unTQSSSteps :: Units -> [TQSSStep] -> (Units, [(Double, Units)])
    unTQSSSteps w []     = (w, [])
    unTQSSSteps w (s:ss) = case unTQSSSteps w' ss of
                             (w'', ys) -> (w'', (fromIntegral (s^.step_price), w') : ys)
      where
        w' = w + s^.step_units

-- | Given a default value 'dflt' and a table 'tbl', compute a total function
-- which interpolates the table.
--
-- Interpolation works as follows, given a input value 'k', find the largest key
-- smaller or equal to 'k' and return the corresponding value.
-- If 'k' is strictly smaller than all the keys of the table then return 'dflt'.
interpolate :: Ord k => v -> [(k, v)] -> k -> v
interpolate dflt tbl = \k -> maybe dflt snd $ Map.lookupLE k m
  where
    m = Map.fromList tbl


-- | Check the validity of the TQSS and solve it using either
-- 'runNormalisedTQSS' or 'runAbsoluteTQSS' as appropriate.
runTQSS :: Goodly bid
        => Auction bid
        -> TQSS TQSSTable
        -> IO (Auction bid, AuctionResult bid, Units, Maybe [TQSSPoint])
runTQSS auction tqss = do
    step <- checkTQSSTable (tqss ^. tqss_fun)
    case tqss' ^. tqss_type of
      TQSSNormalised     -> do checkNormalisedTQSS auction
                               runNormalisedTQSS auction (tqss ^. tqss_fun)
      TQSSAbsolute atqss -> do checkAbsoluteTQSS auction atqss step
                               runAbsoluteTQSS auction (Just (tqss ^. tqss_fun)) (tqss' ^. tqss_fun) atqss
  where
    tqss' = interpolateTQSS tqss


-- | Solve an auction with a normalised TQSS using a single LP solver run and
-- including the TQSS in the structure of the LP.
--
-- The resulting auction will have 'auction_size_limit' set.
runNormalisedTQSS :: Goodly bid
        => Auction bid
        -> TQSSTable
        -> IO (Auction bid, AuctionResult bid, Units, Maybe a)
runNormalisedTQSS auction t = do
    ar <- runAuctionCore "runNormalisedTQSS" auction'
    let r = sum [ u | (TQSSStepVar{}, u) <- Map.toList (ar ^. ar_quantities) ]
    return (auction', ar, roundToScale sf r, Nothing)
  where
    auction' = auction & auction_size_limit .~ Just (TQSSLimit t)
    sf = auction ^. auction_scale


-- | Iteratively solve an auction with a TQSS, by re-running the LP
-- with variable total quantities and using the search strategy to
-- find the smallest quantity for which demand is no less than the
-- TQSS.  Returns the auction scaled to the final size, the
-- prices/allocations at that size, the total size itself and the
-- points of the TQSS graph evaluated to determine it.
--
-- Note that if an additional constraint is being used to fix the
-- auction size, the resulting auction will have 'auction_size_limit'
-- set.
runAbsoluteTQSS :: Goodly bid
        => Auction bid
        -> Maybe [TQSSStep]
        -> TQSSFun
        -> AbsoluteTQSS
        -> IO (Auction bid, AuctionResult bid, Units, Maybe [TQSSPoint])
runAbsoluteTQSS auction mb_steps fun atqss = do
    points <- sortBy (comparing _tqp_demand_target) <$> evalTQSSSearch (atqss ^. atqss_search) fun atqss mb_steps auction
    let tqp           = findIntersection points
        (auction', r) = scaleAuction (atqss ^. atqss_scale) auction (_tqp_demand_target tqp)
    debugPrint v "runAbsoluteTQSS: points"       points
    debugPrint v "runAbsoluteTQSS: intersection" tqp
    debugPrint v "runAbsoluteTQSS: result size"  r
    ar <- runAuctionCore "runAbsoluteTQSS" auction'
    return (auction', ar, r, Just points)
  where
    v = auction ^. auction_verbosity

-- | If a minimum bound for the TQSS search is specified, use it.
-- If not...
--
-- * ... and we are scaling the supply curves, start from the original
--   size of the supply (because we only want to scale up);
--
-- * ... and we are imposing a total quantity constraint, start from 0.
tqssMinBound :: AbsoluteTQSS -> Auction bid -> Units
tqssMinBound atqss auction = fromMaybe default_rmin (atqss ^. atqss_min_bound)
  where
    original_supply = totalSupply (auction ^. auction_supply)
    default_rmin = case atqss ^. atqss_scale of
      ScaleSupply{} -> original_supply
      AddConstraint -> 0

-- | If a maximum bound for the TQSS search is specified, use it.  If not...
--
--  * ... and we are scaling the supply curves, go up to twice the
--    original supply size (this is fairly arbitrary);
--
-- * ... and we are imposing a total quantity constraint, go up to
--   the original supply size (because we can't exceed it anyway).
tqssMaxBound :: AbsoluteTQSS -> Auction bid -> Units
tqssMaxBound atqss auction = fromMaybe default_rmax (atqss ^. atqss_max_bound)
  where
    original_supply = totalSupply (auction ^. auction_supply)
    default_rmax = case atqss ^. atqss_scale of
                     ScaleSupply{} -> original_supply*2
                     AddConstraint -> original_supply

-- | If a step size for the TQSS search is specified, use it.  If not, choose
-- a default step size, given the bounds, such that it makes a fixed
-- number of steps.
tqssStepSize :: AbsoluteTQSS -> Auction bid -> Units
tqssStepSize atqss auction = fromMaybe defaultStepSize (atqss ^. atqss_step_size)
  where
    start = tqssMinBound atqss auction
    stop  = tqssMaxBound atqss auction
    defaultStepSize = (stop - start) / 20

-- | Implement a strategy for changing the total size of the auction.
-- For 'ScaleSupply', this scales and rounds the supply curves.  For
-- 'AddConstraint', this imposes a size limit as a constraint in the
-- LP.  Returns the total size of the resulting auction, which might
-- be different from the size requested due to rounding.
scaleAuction :: TQSSScale -> Auction bid -> Units -> (Auction bid, Units)
scaleAuction mb_lambda auction = case mb_lambda of
    ScaleSupply lambda -> \r -> let auction' = auction & auction_supply %~ scaleSupplyRounded sf lambda r
                                in (auction', roundToScale sf (totalSupply (auction' ^. auction_supply)))
    AddConstraint      -> \r -> let r' = roundToScale sf r
                                in (auction & auction_size_limit .~ Just (FixedLimit r'), r')
  where
    sf = auction ^. auction_scale

-- | Check that the TQSS table is non-empty and non-decreasing, and
-- return the first step.
checkTQSSTable :: TQSSTable -> IO (Step Units)
checkTQSSTable [] = throwIO TQSSEmpty
checkTQSSTable t@(step:_) = do
    unless (isNondecreasingTQSSTable t) $
        throwIO TQSSDecreasing
    return step

checkNormalisedTQSS :: Auction bid -> IO ()
checkNormalisedTQSS auction = unless (isHorizontalSupply supply) $ throwIO TQSSNormalisedNotHorizontal
  where
    supply = auction ^. auction_supply

-- | Check the validity of the TQSS, given the auction and the minimum and maximum
-- bounds of the search.

checkAbsoluteTQSS :: Auction bid -> AbsoluteTQSS -> Step Units -> IO ()
checkAbsoluteTQSS auction atqss first_step = do
    -- Check that any single-good price measure is a valid good
    case atqss ^. atqss_price_measure of
        SingleGoodPrice good
          | good `notElem` auctionGoodLabels auction -> throwIO (TQSSGoodMissing good)
        _                                            -> return ()

    -- If we are using scale supply mode...
    --
    -- - ...with a non-zero lambda, check that the supply ordering is vertical
    --
    -- - ...in all cases, check that the first TQSS step has price 0 and
    --   is no smaller than the auction size
    case atqss ^. atqss_scale of
        ScaleSupply (SupplyScaleLambda lambda)
          | lambda /= 0, not (isVerticalSupply supply) -> throwIO TQSSBadLambda
          | first_step^.step_price /= 0                -> throwIO TQSSFirstStepNonZero
          | first_step^.step_units < auction_size      -> throwIO $ TQSSFirstStepTooSmall (first_step^.step_units) auction_size
        _                                              -> return ()

    -- Check that the upper bound of the search exceeds the lower bound
    when (rmin > rmax) $ throwIO $ TQSSMinAboveMax rmin rmax
  where
    supply = auction ^. auction_supply
    rmin = tqssMinBound atqss auction
    rmax = tqssMaxBound atqss auction
    auction_size = totalSupply supply


-- | Find an approximation to the intersection from amongst the
-- calculated points, which should be sorted and non-empty.  If we do
-- not have a precise solution, we always take the left endpoint of
-- the interval, so that we ensure that the prices are compatible with
-- the TQSS (at the cost of possibly yielding an auction size that is
-- slightly smaller than the true answer).
findIntersection :: [TQSSPoint] -> TQSSPoint
findIntersection xs = case findIntersectionInterval xs of
    Left tqp       -> tqp
    Right (tqp, _) -> tqp

-- | Find the point that exactly satisfies the TQSS, if there is one,
-- or the endpoints of the interval in which the solution lies.
-- Returns the last point of the list if there is no intersection, and
-- throws an error if the list is empty.
findIntersectionInterval :: [TQSSPoint] -> Either TQSSPoint (TQSSPoint, TQSSPoint)
findIntersectionInterval [] = error "findIntersectionInterval: empty list!"
findIntersectionInterval [tqp] = Left tqp
findIntersectionInterval (tqp:tqp':tqps)
      | _tqp_demand tqp == _tqp_supply tqp = Left tqp
      | _tqp_demand tqp < _tqp_supply tqp
      , _tqp_demand tqp' > _tqp_supply tqp' = Right (tqp, tqp')
      | otherwise = findIntersectionInterval (tqp':tqps)


-- | Text label for the prices used by this TQSS type.
tqssTypeLabel :: TQSSType -> T.Text
tqssTypeLabel (TQSSAbsolute atqss) = priceMeasureLabel (atqss ^. atqss_price_measure)
tqssTypeLabel TQSSNormalised       = "Normalised price"

-- | Text label for the prices used with this measure in an absolute
-- TQSS.
priceMeasureLabel :: TQSSPriceMeasure -> T.Text
priceMeasureLabel (SingleGoodPrice g) = "Price of good " <> T.pack (show (_good_index g))
priceMeasureLabel MeanPrice           = "Mean price"