ValueSimplex.hs

   1 module ValueSimplex where
   2 import Control.Applicative ((<$>), (<*>))
   3 import Data.Foldable (foldMap)
   4 import Data.Map (Map)
   5 import qualified Data.Map.Lazy as Map
   6 import Data.Maybe (fromMaybe)
   7 import Data.Monoid (Sum(..))
   8 import Data.Set (Set)
   9 import qualified Data.Set as Set
  10 import Data.Tuple (swap)
  11 import IndexedMatrix
  12 import Numeric.Matrix (MatrixElement)
  13 import Util.Function ((...))
  14 import Util.Set (allSet, anySet)
  15
  16 newtype ValueSimplex a b = VS {vsMap :: Map (a, a) b} deriving (Eq, Show)
  17
  18 data VSStatus
  19   = OK
  20   | WrongPairs
  21   | NonPositive
  22   | CyclesWrong
  23   | Empty
  24   deriving (Show, Eq)
  25
  26 nodes :: Ord a => ValueSimplex a b -> Set a
  27 nodes vs = Set.map fst $ Map.keysSet $ vsMap vs
  28
  29 pairUp :: a -> b -> (a, b)
  30 pairUp = curry id
  31
  32 distinctPairsOneWay :: Ord a => Set a -> Set (a, a)
  33 distinctPairsOneWay xs =
  34   case Set.minView xs of
  35     Nothing -> Set.empty
  36     Just (x, xs') -> Set.union
  37       (distinctPairsOneWay xs') $
  38       Set.map (pairUp x) xs'
  39
  40 distinctPairs :: Ord a => Set a -> Set (a, a)
  41 distinctPairs xs =
  42   let dpow = distinctPairsOneWay xs in
  43   Set.union dpow $ Set.map swap dpow
  44
  45 vsLookupMaybe :: Ord a => ValueSimplex a b -> a -> a -> Maybe b
  46 vsLookupMaybe vs x y = Map.lookup (x, y) $ vsMap vs
  47
  48 vsLookup :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  49 vsLookup = fromMaybe 0 ... vsLookupMaybe
  50
  51 fromFunction :: Ord a => (a -> a -> b) -> Set a -> ValueSimplex a b
  52 fromFunction f xs = VS $ Map.fromSet (uncurry f) $ distinctPairs xs
  53
  54 validTriangle :: (Ord a, Num b) =>
  55   (b -> b -> Bool) -> ValueSimplex a b -> a -> a -> a -> Bool
  56 validTriangle eq vs x y z =
  57   (vsLookup vs x y * vsLookup vs y z * vsLookup vs z x)
  58   `eq` (vsLookup vs z y * vsLookup vs y x * vsLookup vs x z)
  59
  60 status :: (Ord a, Ord b, Num b) =>
  61   (b -> b -> Bool) -> ValueSimplex a b -> VSStatus
  62 status eq vs =
  63   let dPairs = distinctPairs $ nodes vs in
  64   if Map.keysSet (vsMap vs) /= dPairs
  65   then WrongPairs
  66   else if anySet ((<= 0) . (uncurry $ vsLookup vs)) dPairs
  67   then NonPositive
  68   else
  69   case Set.minView $ nodes vs of
  70     Nothing -> Empty
  71     Just (x, xs) ->
  72       if allSet (uncurry $ validTriangle eq vs x) $ distinctPairsOneWay xs
  73       then OK
  74       else CyclesWrong
  75
  76 -- price vs x y is the number of ys required to equal one x in value, according
  77 -- to the internal state of the ValueSimplex vs
  78 price :: (Ord a, Fractional b) => ValueSimplex a b -> a -> a -> Maybe b
  79 price vs x y = (/) <$> vsLookupMaybe vs y x <*> vsLookupMaybe vs x y
  80
  81 nodeValue :: (Ord a, Num b) => ValueSimplex a b -> a -> b
  82 {- This might be faster if it was
  83   implemented in a more complicated way, maybe using Map.splitLookup,
  84   but I think it might be O(n log n) either way.
  85   -}
  86 nodeValue vs x =
  87   getSum $ foldMap (Sum . vsLookup vs x) $ Set.delete x $ nodes vs
  88
  89 linkValueSquared :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  90 linkValueSquared vs x y = vsLookup vs x y * vsLookup vs y x
  91
  92 distributionProportions :: (Ord a, Fractional b, MatrixElement b)
  93   => ValueSimplex a b -> a -> a -> a -> b
  94 distributionProportions vs x0 x1 = let xs = nodes vs in
  95   case
  96     inverse $ indexedMatrix (Set.delete x1 xs) (Set.delete x0 xs) $ \x y ->
  97       if x == y
  98       then - nodeValue vs x
  99       else vsLookup vs x y
 100     of
 101     Nothing -> error "ValueSimplex with non-invertible first minor matrix"
 102     Just m -> flip (at' m) x0
 103
 104 supremumSellable :: (Ord a, Fractional b, MatrixElement b)
 105   => ValueSimplex a b -> a -> a -> b
 106 supremumSellable vs x0 x1 = recip $ distributionProportions vs x0 x1 x1
 107
 108 breakEven :: (Ord a, Fractional b, MatrixElement b)
 109   => ValueSimplex a b -> a -> b -> a -> b
 110 breakEven = error "breakEven not yet defined"
 111 -- -q0 * s x1 x0 / s x0 x1 * qM / (q0 + qM)
 112
 113 update :: (Ord a, Ord b, Fractional b, MatrixElement b)
 114   => ValueSimplex a b -> a -> b -> a -> b -> ValueSimplex a b
 115 {- Suppose the following all hold for some suitable approximate equality (~=):
 116     status (~=) vs == OK
 117     for each i in {0, 1}:
 118       xi is in nodes vs
 119       qMi == supremumSellable vs xi x(1-i)
 120       qi > -qMi
 121     vs' == update vs x0 q0 x1 q1
 122     ss == linkValueSquared vs
 123     ss' == linkValueSquared vs'
 124   Then the following should also hold (unless rounding errors have compounded a
 125   little too much):
 126     status (~=) vs' == OK
 127     nodes vs' == nodes vs
 128     for each i in {0, 1}:
 129       nodeValue vs' xi ~= nodeValue vs xi + qi
 130     for each x in nodes vs other than x0 and x1:
 131       nodeValue vs' x ~= nodeValue vs x
 132     for all distinct x and y in nodes vs:
 133       ss' x y ~= ss x y
 134       || compare (ss' x y) (ss x y) == compare (ss' x0 x1) (ss x0 x1)
 135   If it is additionally the case that
 136     q1 / s x1 x0 >= -q0 / s x0 x1 * qM0 / (q0 + qM0)
 137     where s = vsLookup vs
 138   then it should also be the case that for all distinct x and y in nodes vs,
 139     ss' x y ~= ss x y || ss' x y > ss x y
 140   -}
 141 update vs x0 q0 x1 q1 =
 142   let
 143     s = vsLookup vs
 144     w = distributionProportions vs x0 x1
 145     r i j
 146       | i == x0   = 1 + q0 * w j
 147       | i == x1   = 1 + q1 * (s x0 x1 / s x1 x0) * (w x1 - w j)
 148       | otherwise =
 149         let
 150           r011i = r x0 x1 * r x1 i
 151           r100i = r x1 x0 * r x0 i
 152         in
 153         (r011i * w j + r100i * (w x1 - w j)) /
 154           (r011i * w i + r100i * (w x1 - w i))
 155     s' i j = s i j * r i j
 156   in
 157   fromFunction s' $ nodes vs
 158