ValueSimplex.hs

   1 module ValueSimplex where
   2 import Control.Applicative ((<$>), (<*>))
   3 import Data.Foldable (maximumBy)
   4 import Data.Map (Map)
   5 import qualified Data.Map as Map
   6 import Data.Maybe (fromMaybe, fromJust)
   7 import Data.Set (Set)
   8 import qualified Data.Set as Set
   9 import IndexedMatrix
  10 import Numeric.Matrix (MatrixElement)
  11 import Util.Foldable (sumWith)
  12 import Util.Function ((...))
  13 import Util.Set (allSet, anySet, distinctPairs, distinctPairsOneWay)
  14
  15 newtype ValueSimplex a b = VS {vsMap :: Map (a, a) b} deriving (Eq, Show)
  16
  17 data VSStatus
  18   = OK
  19   | WrongPairs
  20   | NonPositive
  21   | CyclesWrong
  22   | Empty
  23   deriving (Show, Eq)
  24
  25 nodes :: Ord a => ValueSimplex a b -> Set a
  26 nodes vs = Set.map fst $ Map.keysSet $ vsMap vs
  27
  28 isEmpty :: Ord a => ValueSimplex a b -> Bool
  29 isEmpty = Set.null . nodes
  30
  31 pairUp :: a -> b -> (a, b)
  32 pairUp = curry id
  33
  34 vsLookupMaybe :: Ord a => ValueSimplex a b -> a -> a -> Maybe b
  35 vsLookupMaybe vs x y = Map.lookup (x, y) $ vsMap vs
  36
  37 vsLookup :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  38 vsLookup = fromMaybe 0 ... vsLookupMaybe
  39
  40 fromFunction :: Ord a => (a -> a -> b) -> Set a -> ValueSimplex a b
  41 fromFunction f xs = VS $ Map.fromSet (uncurry f) $ distinctPairs xs
  42
  43 validTriangle :: (Ord a, Num b) =>
  44   (b -> b -> Bool) -> ValueSimplex a b -> a -> a -> a -> Bool
  45 validTriangle eq vs x y z =
  46   (vsLookup vs x y * vsLookup vs y z * vsLookup vs z x)
  47   `eq` (vsLookup vs z y * vsLookup vs y x * vsLookup vs x z)
  48
  49 status :: (Ord a, Ord b, Num b) =>
  50   (b -> b -> Bool) -> ValueSimplex a b -> VSStatus
  51 status eq vs =
  52   let dPairs = distinctPairs $ nodes vs in
  53   if Map.keysSet (vsMap vs) /= dPairs
  54   then WrongPairs
  55   else if anySet ((<= 0) . (uncurry $ vsLookup vs)) dPairs
  56   then NonPositive
  57   else
  58   case Set.minView $ nodes vs of
  59     Nothing -> Empty
  60     Just (x, xs) ->
  61       if allSet (uncurry $ validTriangle eq vs x) $ distinctPairsOneWay xs
  62       then OK
  63       else CyclesWrong
  64
  65 -- price vs x y is the number of ys required to equal one x in value, according
  66 -- to the internal state of the ValueSimplex vs
  67 price :: (Ord a, Eq b, Fractional b) => ValueSimplex a b -> a -> a -> b
  68 price vs x y
  69   | x == y      = 1
  70   | s x y == 0  = 0
  71   | otherwise   = s y x / s x y
  72   where s = vsLookup vs
  73
  74 hybridPrice :: (Ord a, Eq b, Floating b) => ValueSimplex a b -> a -> a -> a -> b
  75 {- hybridPrice vs x y z is the value of one sqrt(x * y) in terms of z, according
  76   to vs -}
  77 hybridPrice vs x y z = sqrt $ price vs x z * price vs y z
  78
  79 nodeValue :: (Ord a, Num b) => ValueSimplex a b -> a -> b
  80 {- This might be faster if it was
  81   implemented in a more complicated way, maybe using Map.splitLookup,
  82   but I think it might be O(n log n) either way.
  83   -}
  84 nodeValue vs x = sumWith (vsLookup vs x) $ Set.delete x $ nodes vs
  85
  86 linkValueSquared :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  87 linkValueSquared vs x y = vsLookup vs x y * vsLookup vs y x
  88
  89 halfLinkValue :: (Ord a, Floating b) => ValueSimplex a b -> a -> a -> b
  90 halfLinkValue = sqrt ... linkValueSquared
  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 vs x0 q0 x1 =
 111   let
 112     s = vsLookup vs
 113     qM = supremumSellable vs x0 x1
 114   in
 115   -q0 * (s x1 x0 / s x0 x1) * qM / (q0 + qM)
 116
 117 update :: (Ord a, Ord b, Fractional b, MatrixElement b)
 118   => ValueSimplex a b -> a -> b -> a -> b -> ValueSimplex a b
 119 {- Suppose the following all hold for some suitable approximate equality (~=):
 120     status (~=) vs == OK
 121     for each i in {0, 1}:
 122       xi is in nodes vs
 123       qMi == supremumSellable vs xi x(1-i)
 124       qi > -qMi
 125     vs' == update vs x0 q0 x1 q1
 126     ss == linkValueSquared vs
 127     ss' == linkValueSquared vs'
 128   Then the following should also hold (unless rounding errors have compounded a
 129   little too much):
 130     status (~=) vs' == OK
 131     nodes vs' == nodes vs
 132     for each i in {0, 1}:
 133       nodeValue vs' xi ~= nodeValue vs xi + qi
 134     for each x in nodes vs other than x0 and x1:
 135       nodeValue vs' x ~= nodeValue vs x
 136     for all distinct x and y in nodes vs:
 137       ss' x y ~= ss x y
 138       || compare (ss' x y) (ss x y) == compare (ss' x0 x1) (ss x0 x1)
 139   If it is additionally the case that
 140     q1 / s x1 x0 >= -q0 / s x0 x1 * qM0 / (q0 + qM0)
 141     where s = vsLookup vs
 142   then it should also be the case that for all distinct x and y in nodes vs,
 143     ss' x y ~= ss x y || ss' x y > ss x y
 144   -}
 145 update vs x0 q0 x1 q1 =
 146   let
 147     s = vsLookup vs
 148     w = distributionProportions vs x0 x1
 149     r i j
 150       | i == x0   = 1 + q0 * w j
 151       | i == x1   = 1 + q1 * (s x0 x1 / s x1 x0) * (w x1 - w j)
 152       | otherwise =
 153         let
 154           r011i = r x0 x1 * r x1 i
 155           r100i = r x1 x0 * r x0 i
 156         in
 157         (r011i * w j + r100i * (w x1 - w j)) /
 158           (r011i * w i + r100i * (w x1 - w i))
 159     s' i j = s i j * r i j
 160   in
 161   fromFunction s' $ nodes vs
 162
 163 multiUpdate :: (Ord a, Ord b, Fractional b, MatrixElement b)
 164   => ValueSimplex a b -> (a -> b) -> ValueSimplex a b
 165 {- multiUpdate vs f should have the same set of nodes as vs and should have
 166     nodeValue (multiUpdate vs f) x ~= f x
 167   for all x in nodes vs.
 168   It should also affect linkValueSquared uniformly, as update does.  Ideally, it
 169   should spread this surplus (or deficit) as fairly as possible, like update,
 170   but this is hard to specify precisely, and may be in tension with
 171   computational complexity.
 172   -}
 173 multiUpdate vs nv =
 174   let
 175     xs = nodes vs
 176     q x = nv x - nodeValue vs x
 177     xps = Set.filter ((>) <$> nv <*> nodeValue vs) xs
 178     xns = Set.filter ((<) <$> nv <*> nodeValue vs) xs
 179     mostValuableIncrease vs' x y =
 180       compare (q x * price vs' x y) $ q y
 181     evenSpread xs' vs' = flip fromFunction xs $ \x y ->
 182       if Set.member x xs'
 183       then vsLookup vs' x y * (nv x / nodeValue vs' x)
 184       else vsLookup vs' x y
 185     breakEvenUpdate vs' x0 q0 x1 = update vs' x0 q0 x1 $ breakEven vs' x0 q0 x1
 186     pileUp xmax' xps' vs' = case Set.minView xps' of
 187       Nothing -> vs'
 188       Just (x, xps'') -> pileUp xmax' xps'' $ breakEvenUpdate vs' x (q x) xmax'
 189     unPile xmax' xns' vs' =
 190       let
 191         xmin = maximumBy (mostValuableIncrease vs') xns'
 192           -- i.e., smallest decrease
 193         xns'' = Set.delete xmin xns'
 194         qxmax = nv xmax' - nodeValue vs' xmax'
 195         qxmin = q xmin
 196         beq = breakEven vs' xmax' qxmax xmin
 197       in
 198       if qxmin <= - supremumSellable vs' xmin xmax'
 199         || (not (Set.null xns'') && qxmin < beq)
 200       then evenSpread xns' $ update vs' xmax' qxmax xmin beq
 201       else if Set.null xns''
 202       then update vs' xmax' qxmax xmin qxmin
 203       else unPile xmax' xns'' $ breakEvenUpdate vs' xmin qxmin xmax'
 204   in
 205   if Set.null xps
 206   then evenSpread xns vs
 207   else if Set.null xns
 208   then evenSpread xps vs
 209   else
 210   let
 211     xmax = maximumBy (mostValuableIncrease vs) xps
 212   in
 213   unPile xmax xns $ pileUp xmax (Set.delete xmax xps) vs
 214
 215 linkOptimumAtPrice :: (Ord a, Fractional b)
 216   => ValueSimplex a b -> a -> a -> b -> (b, b)
 217 {- linkOptimumAtPrice vs x0 x1 p == (q0, q1) should imply that q0 x0 should be
 218   bought in exchange for -q1 x1, with q1 = -p * q0, *assuming that the
 219   x0--x1 link is severed from the rest of vs*.  A negative q0 indicates that
 220   some x0 should be sold in exchange for x1 at that price.
 221   -}
 222 linkOptimumAtPrice vs x0 x1 p =
 223   let
 224     s = vsLookup vs
 225     q1 = (/ 2) $ s x0 x1 * p - s x1 x0
 226   in
 227   (-q1 / p, q1)
 228
 229 totalValue :: (Ord a, Eq b, Fractional b) => ValueSimplex a b -> a -> b
 230 -- The value of the ValueSimplex in terms of the given node
 231 totalValue vs x = sumWith ((/) <$> nodeValue vs <*> price vs x) $ nodes vs
 232
 233 addNode :: (Ord a, Eq b, Fractional b)
 234   => ValueSimplex a b -> a -> b -> a -> b -> ValueSimplex a b
 235 {-  vs' == addNode vs x q y p
 236   should imply:
 237     status (~=) vs' == OK
 238     nodes vs' == Set.insert x $ nodes vs
 239     nodeValue vs' x ~= q
 240     price vs' x y ~= p
 241   and for i, j, k, and l in nodes vs:
 242     nodeValue vs' i ~= nodeValue vs i
 243     price vs' i j ~= price vs i j
 244     ss' i j / ss' k l ~= ss i j / ss k l
 245       where
 246         ss = linkValueSquared vs
 247         ss' = linkValueSquared vs'
 248   assuming:
 249     status (~=) vs == OK
 250     Set.notMember x $ nodes vs
 251     Set.member y $ nodes vs
 252     p > 0
 253     q > 0
 254     q * p < totalValue vs y
 255   -}
 256 addNode vs x q y p =
 257   let tv = totalValue vs y in
 258   flip fromFunction (Set.insert x $ nodes vs) $ \i j ->
 259   if i == x
 260   then q * nodeValue vs j * price vs j y / tv
 261   else if j == x
 262   then (q * p / tv) * nodeValue vs i
 263   else (1 - q * p / tv) * vsLookup vs i j
 264
 265 strictlySuperior :: (Ord a, Ord b, Num b)
 266   => (b -> b -> Bool) -> ValueSimplex a b -> ValueSimplex a b -> Bool
 267 strictlySuperior eq vs vs' =
 268   let
 269     comparisons = flip Set.map (distinctPairs $ nodes vs) $ \(x, y) ->
 270       let
 271         ssxy  = linkValueSquared vs   x y
 272         ss'xy = linkValueSquared vs'  x y
 273       in
 274       if ssxy `eq` ss'xy then EQ else compare ssxy ss'xy
 275   in
 276   Set.member GT comparisons && Set.notMember LT comparisons
 277
 278 deposit :: (Ord a, Ord b, Floating b, MatrixElement b)
 279   => ValueSimplex a b -> (a -> b) -> ValueSimplex a b
 280 {-  vs' == deposit vs f
 281   should imply:
 282     status (~=) vs' == OK,
 283     nodes vs' == nodes vs,
 284     nodeValue vs' x ~= f x, and
 285     (v' x y - v x y) * sqrt (price vs y x)
 286       ~= (v' z w - v z w) * sqrt (price vs z x * price vs w x)
 287   assuming:
 288     status (~=) vs == OK,
 289     f x >= nodeValue vs x,
 290     v = sqrt .! linkValueSquared vs, and
 291     v' = sqrt .! linkValueSquared vs'
 292   for all:
 293     distinct x, y in nodes vs, and
 294     distinct z, w in nodes vs
 295   -}
 296 deposit = error "deposit not defined yet"
 297