ValueSimplex.hs

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