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