Strategies.hs

module Tests.Prop.Strategies where

import Control.Monad.Identity (Identity (..))
import Data.Aeson (encode)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Ratio
import GeniusYield.OrderBot.MatchingStrategy
import GeniusYield.OrderBot.OrderBook.List
import GeniusYield.OrderBot.Types
import GeniusYield.Types
import Test.QuickCheck
import qualified Test.QuickCheck.Monadic as M
import Tests.Prop.Utils

{- | Function that creates the boilerplate for the properties.

    Given the strategy and a property over the matches generated by the strategy:
        * Calls the generator
        * Sets up the shrink function
        * Builds the OrderBook
        * Runs the strategy
        * Sets up the counterexample and label
        * Runs the property over the result of running the strategy
-}
mkStrategyTest ::
  IndependentStrategy ->
  ([MatchExecutionInfo] -> Bool) ->
  Property
mkStrategyTest strat prop = forAllShrink genOrderInfos shrinkTuple $
  \(oap, buyOrders, sellOrders) -> M.monadic (\(Identity p) -> p) $ do
    let book = buildOrderBookList [] (# oap, buyOrders, sellOrders #)
    M.pre $ length book == 1
    let meis = uncurry strat $ head book
    M.monitor (counterexample (unlines ["MEIS:", LBS.unpack $ encode meis]))
      >> M.monitor (label (getLabel meis))
      >> M.assert (all prop meis)
 where
  getLabel :: [MatchResult] -> String
  getLabel meis
    | null meis = "No matches found"
    | length meis == 1 = "1 match found"
    | length meis <= 10 = "2-10 matches found"
    | otherwise = "11+ matches found"

{- | Property that checks if the strategy can find a match if one exists.

    This property expects a generator that generates orderbooks with no
    matches, an extra buyOrder and an extra sellOrder that should make a match.

    Given the strategy, and generator:
        * Calls the generator
        * Sets up the shrink function
        * Builds the OrderBook
        * Runs the strategy
        * Checks that there were no matches
        * Build the OrderBook by adding the new sell and buy Orders
        * Runs the strategy again
        * Sets up the counterexample and label
        * Runs the property over the result of running the strategy the second time
-}
propCanFindOnlyMatching ::
  IndependentStrategy ->
  Gen (OrderAssetPair, [OrderInfo 'BuyOrder], [OrderInfo 'SellOrder], OrderInfo 'BuyOrder, OrderInfo 'SellOrder) ->
  Property
propCanFindOnlyMatching strat gen = forAllShrink gen shrinkTuple' $
  \(oap, buyOrders, sellOrders, nBuyOrder, nSellOrder) -> M.monadic (\(Identity p) -> p) $ do
    let book = buildOrderBookList [] (# oap, buyOrders, sellOrders #)
    M.pre $ length book == 1
    let meis = uncurry strat $ head book
    M.pre $ all null meis
    let book' = buildOrderBookList [] (# oap, nBuyOrder : buyOrders, nSellOrder : sellOrders #)
        meis' = uncurry strat $ head book'
    M.monitor (counterexample (unlines ["", "MEIS:", LBS.unpack $ encode meis', "BOOK:", show book']))
      >> M.monitor (label (if null meis then "No matches" else "Matches found"))
      >> M.assert (any (\mr -> length mr >= 2) meis')

{- | Generates a fixes OrderAssetPair, a list of buy and sell orders that
    don't generate any matches because they don't line up on price.
    And an extra buy and sell orders that can be matched togheter.
-}
genOrderInfosWrongPrices :: Gen (OrderAssetPair, [OrderInfo 'BuyOrder], [OrderInfo 'SellOrder], OrderInfo 'BuyOrder, OrderInfo 'SellOrder)
genOrderInfosWrongPrices = do
  buyOrders <- listOf1 $ genBuyOrder' oap
  sellOrders <- listOf1 $ genSellOrder' oap
  newBuyOrder <- genBuyOrder oap
  newSellOrder <- genSellOrder oap `suchThat` sellOrderIsProfitable newBuyOrder
  return (oap, buyOrders, sellOrders, newBuyOrder, newSellOrder)
 where
  goldPolicyId = "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef"
  oap = mkOrderAssetPair GYLovelace (GYToken goldPolicyId "GOLD")

  sellOrderIsProfitable :: OrderInfo 'BuyOrder -> OrderInfo 'SellOrder -> Bool
  sellOrderIsProfitable bOrder sOrder =
    price sOrder <= price bOrder
      && volumeMin (volume sOrder) <= volumeMax (volume bOrder)
      && volumeMin (volume bOrder) <= volumeMax (volume sOrder)

  genBuyOrder' :: OrderAssetPair -> Gen (OrderInfo 'BuyOrder)
  genBuyOrder' oap = do
    price <- genPrice `suchThat` ((< (50 % 1)) . getPrice)
    volume <- genVolume (ceiling $ getPrice price)
    utxoRef <- genGYTxOutRef
    return $ OrderInfo utxoRef SBuyOrder oap volume price Nothing

  genSellOrder' :: OrderAssetPair -> Gen (OrderInfo 'SellOrder)
  genSellOrder' oap =
    OrderInfo
      <$> genGYTxOutRef
      <*> pure SSellOrder
      <*> pure oap
      <*> genVolume 1
      <*> genPrice `suchThat` ((> (50 % 1)) . getPrice)
      <*> pure Nothing

{- | Property that checks if the sum of the offered tokens in the buy orders is
    less than or equal to the sum of offered tokens in the sell orders.
-}
propOffered :: [MatchExecutionInfo] -> Bool
propOffered [] = True
propOffered xs =
  let buys = filter isBuyOrderMEI xs
      sells = filter isSellOrderMEI xs
   in sumOfOffered buys <= sumOfOffered sells

{- | Property that checks if the sum of the price tokens in the buy orders is
    greater than or equal to the sum of price tokens in the sell orders.

    This means that the bot is not using price tokens from it's own wallet to
    make matches.
-}
propPrice :: [MatchExecutionInfo] -> Bool
propPrice [] = True
propPrice xs =
  let buys = filter isBuyOrderMEI xs
      sells = filter isSellOrderMEI xs
   in sumOfPrice buys >= sumOfPrice sells

{- | Property that checks if the matches generated by the strategy can be done
   Complete fill can always be performed and partial fills need to be
    between the min and max volume
-}
propCanExecuteFill :: [MatchExecutionInfo] -> Bool
propCanExecuteFill = all canFill
 where
  canFill :: MatchExecutionInfo -> Bool
  canFill (OrderExecutionInfo CompleteFill _) = True
  canFill (OrderExecutionInfo (PartialFill n) OrderInfo {volume}) =
    n >= volumeMin volume
      && n < volumeMax volume

--------------------------------------------------

-- | UTILS

--------------------------------------------------

-- | Checks if a MatchExecutionInfo is a sell order
isSellOrderMEI :: MatchExecutionInfo -> Bool
isSellOrderMEI (OrderExecutionInfo _ OrderInfo {orderType = SSellOrder}) = True
isSellOrderMEI _ = False

-- | Checks if a MatchExecutionInfo is a buy order
isBuyOrderMEI :: MatchExecutionInfo -> Bool
isBuyOrderMEI (OrderExecutionInfo _ OrderInfo {orderType = SBuyOrder}) = True
isBuyOrderMEI _ = False

-- | Given a list of MatchExecutionInfo, sums the offered tokens filled
sumOfOffered :: [MatchExecutionInfo] -> Natural
sumOfOffered = foldl (\acc -> (+) acc . eiOffered) 0
 where
  eiOffered :: MatchExecutionInfo -> Natural
  eiOffered (OrderExecutionInfo CompleteFill OrderInfo {volume}) = volumeMax volume
  eiOffered (OrderExecutionInfo (PartialFill n) _) = n

-- | Given a list of MatchExecutionInfo, sums the price tokens neccesary for the fills
sumOfPrice :: [MatchExecutionInfo] -> Natural
sumOfPrice = foldl (\acc -> (+) acc . eiOfferedByPrice) 0
 where
  eiOfferedByPrice :: MatchExecutionInfo -> Natural
  eiOfferedByPrice (OrderExecutionInfo CompleteFill OrderInfo {volume, price}) =
    ceiling $ (toInteger (volumeMax volume) % 1) * getPrice price
  eiOfferedByPrice (OrderExecutionInfo (PartialFill n) OrderInfo {price}) =
    ceiling $ (toInteger n % 1) * getPrice price

{- | Shrink function for the CanFindOnlyMatching property.

    Shrinks, in order:
        * Buy Orders
        * Sell Orders
        * The extra buy order
        * The extra sell order
-}
shrinkTuple' ::
  (OrderAssetPair, [OrderInfo 'BuyOrder], [OrderInfo 'SellOrder], OrderInfo 'BuyOrder, OrderInfo 'SellOrder) ->
  [(OrderAssetPair, [OrderInfo 'BuyOrder], [OrderInfo 'SellOrder], OrderInfo 'BuyOrder, OrderInfo 'SellOrder)]
shrinkTuple' (oap, xs, ys, bo, so) =
  [(oap, xs', ys, bo, so) | xs' <- shrinkList shrinkOrderInfo xs]
    ++ [(oap, xs, ys', bo, so) | ys' <- shrinkList shrinkOrderInfo ys]
    ++ [ (oap, xs, ys, bo', so)
       | bo' <- shrinkOrderInfo bo
       , volumeMin (volume so) < volumeMax (volume bo')
       , price so < price bo'
       ]
    ++ [ (oap, xs, ys, bo, so')
       | so' <- shrinkOrderInfo so
       , volumeMin (volume bo) < volumeMax (volume so')
       ]