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 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 qualified Util.Map as Map
  15 import Util.Set (allSet, anySet)
  16
  17 newtype ValueSimplex a b = VS {vsMap :: Map (a, a) b} deriving (Eq, Show)
  18
  19 data VSStatus
  20   = OK
  21   | WrongPairs
  22   | NonPositive
  23   | CyclesWrong
  24   | Empty
  25   deriving (Show, Eq)
  26
  27 nodes :: Ord a => ValueSimplex a b -> Set a
  28 nodes vs = Set.map fst $ Map.keysSet $ vsMap vs
  29
  30 pairUp :: a -> b -> (a, b)
  31 pairUp = curry id
  32
  33 distinctPairsOneWay :: Ord a => Set a -> Set (a, a)
  34 distinctPairsOneWay xs =
  35   case Set.minView xs of
  36     Nothing -> Set.empty
  37     Just (x, xs') -> Set.union
  38       (distinctPairsOneWay xs') $
  39       Set.map (pairUp x) xs'
  40
  41 distinctPairs :: Ord a => Set a -> Set (a, a)
  42 distinctPairs xs =
  43   let dpow = distinctPairsOneWay xs in
  44   Set.union dpow $ Set.map swap dpow
  45
  46 vsLookupMaybe :: Ord a => ValueSimplex a b -> a -> a -> Maybe b
  47 vsLookupMaybe vs x y = Map.lookup (x, y) $ vsMap vs
  48
  49 vsLookup :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  50 vsLookup = fromMaybe 0 ... vsLookupMaybe
  51
  52 fromFunction :: Ord a => (a -> a -> b) -> Set a -> ValueSimplex a b
  53 fromFunction f xs = VS $ Map.fromSet (uncurry f) $ distinctPairs xs
  54
  55 validTriangle :: (Ord a, Num b) =>
  56   (b -> b -> Bool) -> ValueSimplex a b -> a -> a -> a -> Bool
  57 validTriangle eq vs x y z =
  58   (vsLookup vs x y * vsLookup vs y z * vsLookup vs z x)
  59   `eq` (vsLookup vs z y * vsLookup vs y x * vsLookup vs x z)
  60
  61 status :: (Ord a, Ord b, Num b) =>
  62   (b -> b -> Bool) -> ValueSimplex a b -> VSStatus
  63 status eq vs =
  64   let dPairs = distinctPairs $ nodes vs in
  65   if Map.keysSet (vsMap vs) /= dPairs
  66   then WrongPairs
  67   else if anySet ((<= 0) . (uncurry $ vsLookup vs)) dPairs
  68   then NonPositive
  69   else
  70   case Set.minView $ nodes vs of
  71     Nothing -> Empty
  72     Just (x, xs) ->
  73       if allSet (uncurry $ validTriangle eq vs x) $ distinctPairsOneWay xs
  74       then OK
  75       else CyclesWrong
  76
  77 -- price vs x y is the number of ys required to equal one x in value, according
  78 -- to the internal state of the ValueSimplex vs
  79 price :: (Ord a, Fractional b) => ValueSimplex a b -> a -> a -> Maybe b
  80 price vs x y = (/) <$> vsLookupMaybe vs y x <*> vsLookupMaybe vs x y
  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 =
  88   getSum $ foldMap (Sum . vsLookup vs x) $ Set.delete x $ nodes vs
  89
  90 linkValueSquared :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  91 linkValueSquared vs x y = vsLookup vs x y * vsLookup vs y x
  92
  93 distributionProportions :: (Ord a, Fractional b, MatrixElement b)
  94   => ValueSimplex a b -> a -> a -> a -> b
  95 distributionProportions vs x0 x1 = let xs = nodes vs in
  96   case
  97     inverse $ indexedMatrix (Set.delete x1 xs) (Set.delete x0 xs) $ \x y ->
  98       if x == y
  99       then - nodeValue vs x
 100       else vsLookup vs x y
 101     of
 102     Nothing -> error "ValueSimplex with non-invertible first minor matrix"
 103     Just m -> flip (at' m) x0
 104
 105 supremumSellable :: (Ord a, Fractional b, MatrixElement b)
 106   => ValueSimplex a b -> a -> a -> b
 107 supremumSellable vs x0 x1 = recip $ distributionProportions vs x0 x1 x1
 108
 109 breakEven :: (Ord a, Fractional b, MatrixElement b)
 110   => ValueSimplex a b -> a -> b -> a -> b
 111 breakEven vs x0 q0 x1 =
 112   let
 113     s = vsLookup vs
 114     qM = supremumSellable vs x0 x1
 115   in
 116   -q0 * (s x1 x0 / s x0 x1) * qM / (q0 + qM)
 117
 118 update :: (Ord a, Ord b, Fractional b, MatrixElement b)
 119   => ValueSimplex a b -> a -> b -> a -> b -> ValueSimplex a b
 120 {- Suppose the following all hold for some suitable approximate equality (~=):
 121     status (~=) vs == OK
 122     for each i in {0, 1}:
 123       xi is in nodes vs
 124       qMi == supremumSellable vs xi x(1-i)
 125       qi > -qMi
 126     vs' == update vs x0 q0 x1 q1
 127     ss == linkValueSquared vs
 128     ss' == linkValueSquared vs'
 129   Then the following should also hold (unless rounding errors have compounded a
 130   little too much):
 131     status (~=) vs' == OK
 132     nodes vs' == nodes vs
 133     for each i in {0, 1}:
 134       nodeValue vs' xi ~= nodeValue vs xi + qi
 135     for each x in nodes vs other than x0 and x1:
 136       nodeValue vs' x ~= nodeValue vs x
 137     for all distinct x and y in nodes vs:
 138       ss' x y ~= ss x y
 139       || compare (ss' x y) (ss x y) == compare (ss' x0 x1) (ss x0 x1)
 140   If it is additionally the case that
 141     q1 / s x1 x0 >= -q0 / s x0 x1 * qM0 / (q0 + qM0)
 142     where s = vsLookup vs
 143   then it should also be the case that for all distinct x and y in nodes vs,
 144     ss' x y ~= ss x y || ss' x y > ss x y
 145   -}
 146 update vs x0 q0 x1 q1 =
 147   let
 148     s = vsLookup vs
 149     w = distributionProportions vs x0 x1
 150     r i j
 151       | i == x0   = 1 + q0 * w j
 152       | i == x1   = 1 + q1 * (s x0 x1 / s x1 x0) * (w x1 - w j)
 153       | otherwise =
 154         let
 155           r011i = r x0 x1 * r x1 i
 156           r100i = r x1 x0 * r x0 i
 157         in
 158         (r011i * w j + r100i * (w x1 - w j)) /
 159           (r011i * w i + r100i * (w x1 - w i))
 160     s' i j = s i j * r i j
 161   in
 162   fromFunction s' $ nodes vs
 163
 164 multiUpdate :: (Ord a, Ord b, Fractional b, MatrixElement b)
 165   => ValueSimplex a b -> (a -> b) -> ValueSimplex a b
 166 {- multiUpdate vs f should have the same set of nodes as vs and should have
 167     nodeValue (multiUpdate vs f) x ~= f x
 168   for all x in nodes vs.
 169   It should also affect linkValueSquared uniformly, as update does.  Ideally, it
 170   should spread this surplus (or deficit) as fairly as possible, like update,
 171   but this is hard to specify precisely, and may be in tension with
 172   computational complexity.
 173   -}
 174 multiUpdate = error "multiUpdate not yet implemented"
 175