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