Test/ValueSimplex.hs

   1 {-# LANGUAGE RankNTypes
   2   , ScopedTypeVariables
   3   , TemplateHaskell
   4   #-}
   5 module Test.ValueSimplex where
   6 import Prelude hiding (all)
   7 import Control.Applicative ((<$>), (<*>))
   8 import Data.Foldable (all)
   9 import Data.Function (on)
  10 import Data.Map (Map)
  11 import qualified Data.Map as Map
  12 import Data.Maybe (fromJust)
  13 import Data.Ratio ((%))
  14 import Data.Set (Set)
  15 import qualified Data.Set as Set
  16 import Numeric.Matrix (MatrixElement)
  17 import Test.QuickCheck
  18 import Test.QuickCheck.All
  19 import Test.Set
  20 import Util.ApproxEq
  21 import Util.Function ((.!), (....))
  22 import Util.Monad ((>>=*))
  23 import Util.Set (distinctPairs, distinctPairsOneWay)
  24 import ValueSimplex
  25
  26 --------------------------------------------------------------------------------
  27
  28 instance Fractional a => Fractional (Positive a) where
  29   Positive x / Positive y = Positive $ x / y
  30   recip (Positive x) = Positive $ recip x
  31   fromRational = Positive . fromRational
  32
  33 liftEquivToValueSimplex :: (Ord a, Num b) =>
  34   (b -> b -> Bool) -> ValueSimplex a b -> ValueSimplex a b -> Bool
  35 liftEquivToValueSimplex eq vs vs' = let xs = nodes vs
  36     in nodes vs' == xs
  37     &&  ( flip all (distinctPairs xs) $ \(x, y) ->
  38             vsLookup vs x y `eq` vsLookup vs' x y
  39         )
  40
  41 instance (Ord a, Num b, RelApproxEq b) => RelApproxEq (ValueSimplex a b) where
  42   (~~=) = liftEquivToValueSimplex (~~=)
  43
  44 validify :: (Ord a, Fractional b) => a -> (a -> a -> b) -> a -> a -> b
  45 validify x f y z =
  46   if y < z || y == x || z == x
  47   then f y z
  48   else f z y * f y x * f x z / (f z x * f x y)
  49
  50 instance
  51   (Arbitrary a, CoArbitrary a, Ord a, Arbitrary b, Ord b, Fractional b) =>
  52   Arbitrary (ValueSimplex a b) where
  53   arbitrary = do
  54     x <- arbitrary
  55     f <- arbitrary
  56     xs <- arbitrarySetOfSizeSqrtOrMin 2
  57     return $ fromFunction (validify x $ getPositive .! f) xs
  58
  59 --------------------------------------------------------------------------------
  60
  61 withArbitraryNode :: (Ord a, Show a, Testable p)
  62   => ValueSimplex a b -> (a -> p) -> Property
  63 withArbitraryNode = withArbitraryElement . nodes
  64
  65 with2ArbitraryNodes :: (Ord a, Show a, Testable p)
  66   => ValueSimplex a b -> (a -> a -> p) -> Property
  67 with2ArbitraryNodes = with2ArbitraryElements . nodes
  68
  69 testList :: Testable p => [a -> p] -> a -> Property
  70 testList ts x = foldr (.&&.) (property True) $ map ($ x) ts
  71
  72 --------------------------------------------------------------------------------
  73
  74 vsLookup_fromFunction ::
  75   (Arbitrary a, CoArbitrary a, Ord a, Show a, Arbitrary b, Eq b, Num b) =>
  76   Blind (a -> a -> b) -> Property
  77 vsLookup_fromFunction (Blind f) = forAll arbitrarySetOfSizeSqrt $ \xs ->
  78     with2ArbitraryElements xs $ \x y ->
  79       vsLookup (fromFunction f xs) x y == f x y
  80
  81 prop_vsLookup_fromFunction_Double ::
  82   (Arbitrary a, CoArbitrary a, Ord a, Show a) =>
  83   Blind (a -> a -> Double) -> Property
  84 prop_vsLookup_fromFunction_Double = vsLookup_fromFunction
  85
  86 nodes_fromFunction ::
  87   (Arbitrary a, CoArbitrary a, Ord a, Show a, Arbitrary b) =>
  88   Blind (a -> a -> b) -> Property
  89 nodes_fromFunction (Blind f) = forAll (arbitrarySetOfSizeSqrtOrMin 2) $
  90   \xs -> nodes (fromFunction f xs) == xs
  91
  92 prop_nodes_fromFunction_Double :: (Arbitrary a, CoArbitrary a, Ord a, Show a)
  93   => Blind (a -> a -> Double) -> Property
  94 prop_nodes_fromFunction_Double = nodes_fromFunction
  95
  96 prop_empty :: (Arbitrary a, CoArbitrary a, Ord a, Show a)
  97   => Blind (a -> a -> Double) -> Bool
  98 prop_empty (Blind f) = isEmpty $ fromFunction f Set.empty
  99
 100 --------------------------------------------------------------------------------
 101
 102 fromFunction_vsLookup :: (Ord a, Eq b, Num b) => ValueSimplex a b -> Bool
 103 fromFunction_vsLookup vs = fromFunction (vsLookup vs) (nodes vs) == vs
 104
 105 values_positive :: (Ord a, Show a, Ord b, Num b) => ValueSimplex a b -> Property
 106 values_positive vs = with2ArbitraryNodes vs $ (0 <) .! vsLookup vs
 107
 108 non_degenerate :: Ord a => ValueSimplex a b -> Bool
 109 non_degenerate = (2 <=) . Set.size . nodes
 110
 111 exact_ValueSimplex_validity_tests :: (Ord a, Show a, Ord b, Num b)
 112   => ValueSimplex a b -> Property
 113 exact_ValueSimplex_validity_tests = testList
 114   [ printTestCase "fromFunction_vsLookup" . fromFunction_vsLookup
 115   , printTestCase "values_positive" . values_positive
 116   , printTestCase "non_degenerate" . non_degenerate
 117   , printTestCase "non-empty" . not . isEmpty
 118   ]
 119
 120 prop_exact_ValueSimplex_validity_tests_Double :: (Ord a, Show a)
 121   => ValueSimplex a Double -> Property
 122 prop_exact_ValueSimplex_validity_tests_Double =
 123   exact_ValueSimplex_validity_tests
 124
 125 --------------------------------------------------------------------------------
 126
 127 approx_Double_exact_Rational ::
 128   forall t. Testable t =>
 129   (forall b. (Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b) =>
 130       (b -> b -> Bool) -> ValueSimplex Integer b -> t) ->
 131     Property
 132 approx_Double_exact_Rational test =
 133   (test (~~=) :: ValueSimplex Integer Double -> t)
 134   .&&.  (test (==) :: ValueSimplex Integer Rational -> t)
 135
 136 ok :: (Ord a, Ord b, Num b) => (b -> b -> Bool) -> ValueSimplex a b -> Bool
 137 ok = (OK ==) .! status
 138
 139 could_have_been_arbitrary :: (Ord a, Show a, Fractional b) =>
 140   (b -> b -> Bool) -> ValueSimplex a b -> Property
 141 could_have_been_arbitrary eq vs = let xs = nodes vs in
 142   withArbitraryNode vs $ \x ->
 143     liftEquivToValueSimplex eq vs $ fromFunction (validify x $ vsLookup vs) xs
 144
 145 approx_ValueSimplex_validity_tests :: (Ord a, Show a, Ord b, Fractional b)
 146   => (b -> b -> Bool) -> ValueSimplex a b -> Property
 147 approx_ValueSimplex_validity_tests = curry $ testList $ map uncurry
 148   [ printTestCase "ok" .! ok
 149   , printTestCase "could_have_been_arbitrary" .! could_have_been_arbitrary
 150   ]
 151
 152 prop_approx_ValueSimplex_validity_tests :: Property
 153 prop_approx_ValueSimplex_validity_tests =
 154   approx_Double_exact_Rational approx_ValueSimplex_validity_tests
 155
 156 --------------------------------------------------------------------------------
 157
 158 prop_price_self :: (Ord a, Show a) => ValueSimplex a Double -> Property
 159 prop_price_self vs = withArbitraryNode vs $ \x -> price vs x x == 1
 160
 161 compoundPrice :: (Ord a, Eq b, Fractional b)
 162   => ValueSimplex a b -> a -> a -> a -> b
 163 compoundPrice vs x y z = ((*) `on` uncurry (price vs)) (x, y) (y, z)
 164
 165 equal_values :: (Ord a, Show a, Eq b, Fractional b) =>
 166   (b -> b -> Bool) -> ValueSimplex a b -> Property
 167 equal_values eq vs = with2ArbitraryNodes vs $ \x y ->
 168   (vsLookup vs x y * price vs x y) `eq` vsLookup vs y x
 169
 170 prop_equal_values :: Property
 171 prop_equal_values = approx_Double_exact_Rational equal_values
 172
 173 prices_reciprocal :: (Ord a, Show a, Eq b, Fractional b) =>
 174   (b -> b -> Bool) -> ValueSimplex a b -> Property
 175 prices_reciprocal eq vs = with2ArbitraryNodes vs $ \x y ->
 176   compoundPrice vs x y x `eq` 1
 177
 178 prop_prices_reciprocal :: Property
 179 prop_prices_reciprocal = approx_Double_exact_Rational prices_reciprocal
 180
 181 price_cycle :: (Ord a, Show a, Eq b, Fractional b) =>
 182   (b -> b -> Bool) -> ValueSimplex a b -> Property
 183 price_cycle eq vs = with3ArbitraryElements (nodes vs) $ \x y z ->
 184   compoundPrice vs x y z `eq` price vs x z
 185
 186 prop_price_cycle :: Property
 187 prop_price_cycle = approx_Double_exact_Rational price_cycle
 188
 189 prop_hybridPrice_correct :: (Ord a, Show a) => ValueSimplex a Double -> Property
 190 prop_hybridPrice_correct vs = with2ArbitraryNodes vs $ \x y ->
 191   withArbitraryNode vs $ \z ->
 192   (hybridPrice vs x y z) ^ 2 ~~= price vs x z * price vs y z
 193
 194 --------------------------------------------------------------------------------
 195
 196 nodeValue_correct :: (Ord a, Show a, Num b)
 197   => (b -> b -> Bool) -> ValueSimplex a b -> Property
 198 nodeValue_correct eq vs = let xs = nodes vs in
 199   withArbitraryElementAndRest xs $ \x xs' ->
 200     nodeValue vs x `eq` Set.foldr ((+) . vsLookup vs x) 0 xs'
 201
 202 prop_nodeValue_correct :: Property
 203 prop_nodeValue_correct = approx_Double_exact_Rational nodeValue_correct
 204
 205 linkValueSquared_correct :: (Ord a, Show a, Eq b, Num b)
 206   => ValueSimplex a b -> Property
 207 linkValueSquared_correct vs = with2ArbitraryNodes vs $ \x y ->
 208   linkValueSquared vs x y == vsLookup vs x y * vsLookup vs y x
 209
 210 prop_linkValueSquared_correct_Double :: (Ord a, Show a)
 211   => ValueSimplex a Double -> Property
 212 prop_linkValueSquared_correct_Double = linkValueSquared_correct
 213
 214 prop_halfLinkValue_correct :: (Ord a, Show a)
 215   => ValueSimplex a Double -> Property
 216 prop_halfLinkValue_correct vs = with2ArbitraryNodes vs $ \x y ->
 217   (halfLinkValue vs x y) ^ 2 ~~= linkValueSquared vs x y
 218
 219 --------------------------------------------------------------------------------
 220
 221 sell_too_much ::
 222   (Ord a, Show a, Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b)
 223   => ValueSimplex a b -> Property
 224 sell_too_much vs = with2ArbitraryNodes vs $ \x0 x1 ->
 225   forAll (arbitrary `suchThat` (<= - supremumSellable vs x0 x1)) $ \q0 ->
 226   property $ \q1 -> vsLookup (update vs x0 q0 x1 q1) x0 x1 <= 0
 227
 228 prop_sell_too_much_Double :: (Ord a, Show a)
 229   => ValueSimplex a Double -> Property
 230 prop_sell_too_much_Double = sell_too_much
 231
 232 arbitrarySellable ::
 233   (Ord a, Show a, Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b)
 234   => ValueSimplex a b -> a -> a -> Gen b
 235 arbitrarySellable vs x0 x1 =
 236   arbitrary `suchThat` (> - supremumSellable vs x0 x1)
 237
 238 withSomeArbitraryUpdateParameters ::
 239   ( Ord a, Show a
 240   , Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b
 241   , Testable p
 242   )
 243   => ValueSimplex a b -> (a -> b -> a -> p) -> Property
 244 withSomeArbitraryUpdateParameters vs t = with2ArbitraryNodes vs $ \x0 x1 ->
 245   forAll (arbitrarySellable vs x0 x1) $ flip (t x0) x1
 246
 247 breakEven_sellable ::
 248   (Ord a, Show a, Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b)
 249   => ValueSimplex a b -> Property
 250 breakEven_sellable vs = withSomeArbitraryUpdateParameters vs $ \x0 q0 x1 ->
 251   breakEven vs x0 q0 x1 > - supremumSellable vs x1 x0
 252
 253 prop_breakEven_sellable_Double :: (Ord a, Show a)
 254   => ValueSimplex a Double -> Property
 255 prop_breakEven_sellable_Double = breakEven_sellable
 256
 257 update_symmetric ::
 258   (Ord a, Show a, Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b)
 259   => (b -> b -> Bool) -> ValueSimplex a b -> Property
 260 update_symmetric eq vs = with2ArbitraryNodes vs $ \x0 x1 -> property $ \q0 q1 ->
 261   liftEquivToValueSimplex eq (update vs x0 q0 x1 q1) (update vs x1 q1 x0 q0)
 262
 263 prop_update_symmetric :: Property
 264 prop_update_symmetric = approx_Double_exact_Rational update_symmetric
 265
 266 prop_update_zero :: Property
 267 prop_update_zero = approx_Double_exact_Rational $ \eq vs ->
 268   with2ArbitraryNodes vs $ \x0 x1 ->
 269   liftEquivToValueSimplex eq vs $ update vs x0 0 x1 0
 270
 271 withArbitraryUpdateParameters ::
 272   ( Ord a, Show a
 273   , Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b
 274   , Testable p
 275   )
 276   => ValueSimplex a b -> (a -> b -> a -> b -> p) -> Property
 277 withArbitraryUpdateParameters vs t =
 278   withSomeArbitraryUpdateParameters vs $ \x0 q0 x1 ->
 279   forAll (arbitrarySellable vs x1 x0) $ t x0 q0 x1
 280
 281 prop_update_exact_ValueSimplex_validity_tests_Double :: (Ord a, Show a)
 282   => ValueSimplex a Double -> Property
 283 prop_update_exact_ValueSimplex_validity_tests_Double vs =
 284   withArbitraryUpdateParameters vs $
 285   exact_ValueSimplex_validity_tests .... update vs
 286
 287 prop_update_approx_ValueSimplex_validity_tests :: Property
 288 prop_update_approx_ValueSimplex_validity_tests =
 289   approx_Double_exact_Rational $ \eq vs ->
 290   withArbitraryUpdateParameters vs $
 291   approx_ValueSimplex_validity_tests eq .... update vs
 292
 293 prop_update_nodes_unchanged_Double :: (Ord a, Show a)
 294   => ValueSimplex a Double -> Property
 295 prop_update_nodes_unchanged_Double vs = withArbitraryUpdateParameters vs $
 296   ((nodes vs ==) . nodes) .... update vs
 297
 298 prop_update_changed_nodeValue :: Property
 299 prop_update_changed_nodeValue = approx_Double_exact_Rational $ \eq vs ->
 300   withArbitraryUpdateParameters vs $ \x0 q0 x1 q1 ->
 301   let vs' = update vs x0 q0 x1 q1 in
 302   nodeValue vs' x0 `eq` (nodeValue vs x0 + q0)
 303   && nodeValue vs' x1 `eq` (nodeValue vs x1 + q1)
 304
 305 prop_update_unchanged_nodeValue :: Property
 306 prop_update_unchanged_nodeValue = approx_Double_exact_Rational $ \eq vs ->
 307   withArbitraryUpdateParameters vs $ \x0 q0 x1 q1 ->
 308   withArbitraryElement (Set.difference (nodes vs) $ Set.fromList [x0, x1]) $
 309   \x -> nodeValue (update vs x0 q0 x1 q1) x `eq` nodeValue vs x
 310
 311 prop_uniform_value_change :: Property
 312 prop_uniform_value_change = approx_Double_exact_Rational $ \eq vs ->
 313   withArbitraryUpdateParameters vs $ \x0 q0 x1 q1 ->
 314   with2ArbitraryNodes vs $ \x y ->
 315   let
 316     ss = linkValueSquared vs
 317     ss' = linkValueSquared $ update vs x0 q0 x1 q1
 318   in
 319   ss' x y `eq` ss x y
 320   || compare (ss' x y) (ss x y) == compare (ss' x0 x1) (ss x0 x1)
 321
 322 prop_profit_Double :: (Ord a, Show a) => ValueSimplex a Double -> Property
 323 prop_profit_Double vs = withSomeArbitraryUpdateParameters vs $ \x0 q0 x1 ->
 324   forAll (arbitrary `suchThat` (> breakEven vs x0 q0 x1)) $ \q1 ->
 325   linkValueSquared (update vs x0 q0 x1 q1) x0 x1 > linkValueSquared vs x0 x1
 326
 327 prop_breakEven :: Property
 328 prop_breakEven = approx_Double_exact_Rational $ \eq vs ->
 329   withSomeArbitraryUpdateParameters vs $ \x0 q0 x1 ->
 330   linkValueSquared (update vs x0 q0 x1 (breakEven vs x0 q0 x1)) x0 x1
 331   `eq` linkValueSquared vs x0 x1
 332
 333 prop_loss_Double :: (Ord a, Show a) => ValueSimplex a Double -> Property
 334 prop_loss_Double vs = withSomeArbitraryUpdateParameters vs $ \x0 q0 x1 ->
 335   forAll (choose (- supremumSellable vs x1 x0, breakEven vs x0 q0 x1)) $ \q1 ->
 336   linkValueSquared (update vs x0 q0 x1 q1) x0 x1 < linkValueSquared vs x0 x1
 337
 338 arbitrarilyUpdatedValueSimplex ::
 339   (Ord a, Show a, Arbitrary b, Ord b, Show b, Fractional b, MatrixElement b)
 340   => ValueSimplex a b -> Gen (ValueSimplex a b)
 341 arbitrarilyUpdatedValueSimplex vs = let xs = nodes vs in
 342   if Set.size xs < 2
 343   then return vs
 344   else do
 345     x0 <- elements $ Set.toList xs
 346     x1 <- elements $ Set.toList $ Set.delete x0 xs
 347     q0 <- arbitrarySellable vs x0 x1
 348     q1 <- arbitrarySellable vs x1 x0
 349     return $ update vs x0 q0 x1 q1
 350
 351 longrun_validity :: (Ord a, Show a)
 352   => (ValueSimplex a Double -> Gen (ValueSimplex a Double))
 353   -> ValueSimplex a Double -> Property
 354 longrun_validity upd vs =
 355   sized $ \n -> do
 356     k <- choose (0, n)
 357     forAll
 358       (vs >>=* replicate k upd)
 359       $ approx_ValueSimplex_validity_tests (~~=)
 360
 361 prop_longrun_validity :: (Ord a, Show a) => ValueSimplex a Double -> Property
 362 prop_longrun_validity = longrun_validity arbitrarilyUpdatedValueSimplex
 363
 364 --------------------------------------------------------------------------------
 365
 366 prop_multiUpdate_nodes_unchanged :: Ord a
 367   => ValueSimplex a Double -> Blind (a -> Double) -> Bool
 368 prop_multiUpdate_nodes_unchanged vs (Blind f) =
 369   nodes (multiUpdate vs f) == nodes vs
 370
 371 prop_multiUpdate_nodeValue :: Property
 372 prop_multiUpdate_nodeValue = approx_Double_exact_Rational $ \eq vs ->
 373   property $ \(Blind f') -> let f = getPositive . f' in
 374   withArbitraryNode vs $
 375   eq <$> nodeValue (multiUpdate vs f) <*> f
 376
 377 prop_multiUpdate_uniform_value_change :: Property
 378 prop_multiUpdate_uniform_value_change = approx_Double_exact_Rational $ \eq vs ->
 379   property $ \(Blind f) ->
 380   with2ArbitraryNodes vs $ \x y ->
 381   with2ArbitraryNodes vs $ \i j ->
 382   let
 383     ss = linkValueSquared vs
 384     ss' = linkValueSquared $ multiUpdate vs $ getPositive . f
 385     ssxy = ss x y
 386     ssij = ss i j
 387     ss'xy = ss' x y
 388     ss'ij = ss' i j
 389   in
 390   compare ss'xy ssxy == compare ss'ij ssij || ss'xy `eq` ssxy || ss'ij `eq` ssij
 391
 392 multiUpdateWithAdjustmentList :: (Ord a, Ord b, Fractional b, MatrixElement b)
 393   => ValueSimplex a b -> [(a, b)] -> ValueSimplex a b
 394 multiUpdateWithAdjustmentList vs xqs = multiUpdate vs $ \x ->
 395   nodeValue vs x + Map.findWithDefault 0 x (Map.fromListWith (+) xqs)
 396
 397 generated_multiUpdate_improving :: (Ord a, Show a)
 398   => ValueSimplex a Double
 399   -> (Set a -> Set (a, a))
 400   -> (a -> a -> Gen (Double, Double))
 401   -> Property
 402 generated_multiUpdate_improving vs pairf qgen =
 403   forAll (arbitrarySubset $ pairf $ nodes vs) $ \xxs ->
 404   forAll
 405     (promote $ flip map (Set.toList xxs) $ \(x0, x1) -> do
 406       (q0, q1) <- qgen x0 x1
 407       return [(x0, q0), (x1, q1)]
 408     ) $ \xqs ->
 409   with2ArbitraryNodes vs $ \x y ->
 410   linkValueSquared vs x y <=
 411   linkValueSquared (multiUpdateWithAdjustmentList vs $ concat xqs) x y
 412
 413 prop_multiUpdate_improving :: (Ord a, Show a)
 414   => ValueSimplex a Double -> Property
 415 prop_multiUpdate_improving vs =
 416   let
 417     s = vsLookup vs
 418     ss = linkValueSquared vs
 419   in
 420   generated_multiUpdate_improving vs distinctPairsOneWay $ \x0 x1 -> do
 421     q0 <- arbitrary `suchThat` (> - s x0 x1)
 422     q1 <- arbitrary `suchThat`
 423       (\q -> (s x0 x1 + q0) * (s x1 x0 + q) >= ss x0 x1)
 424     return (q0, q1)
 425
 426 prop_multiUpdate_exact_validity_tests :: (Ord a, Show a)
 427   => ValueSimplex a Double -> Blind (a -> Positive Double) -> Property
 428 prop_multiUpdate_exact_validity_tests vs (Blind f) =
 429   prop_exact_ValueSimplex_validity_tests_Double $
 430     multiUpdate vs $ getPositive . f
 431
 432 prop_multiUpdate_approx_validity_tests :: Property
 433 prop_multiUpdate_approx_validity_tests =
 434   approx_Double_exact_Rational $ \eq vs ->
 435   property $ \(Blind f) ->
 436   approx_ValueSimplex_validity_tests eq $ multiUpdate vs $ getPositive . f
 437
 438 --------------------------------------------------------------------------------
 439
 440 prop_linkOptimumAtPrice_optimum :: (Ord a, Show a) =>
 441   ValueSimplex a Double -> Positive Double -> Double -> Property
 442 prop_linkOptimumAtPrice_optimum vs (Positive p) q =
 443   with2ArbitraryNodes vs $ \x0 x1 ->
 444   let
 445     s = vsLookup vs
 446     ss' q0 q1 = (s x0 x1 + q0) * (s x1 x0 + q1)
 447   in
 448   ss' q (-p * q) <= uncurry ss' (linkOptimumAtPrice vs x0 x1 p)
 449
 450 prop_linkOptimumAtPrice_at_price :: Property
 451 prop_linkOptimumAtPrice_at_price = approx_Double_exact_Rational $ \eq vs ->
 452   with2ArbitraryNodes vs $ \x0 x1 ->
 453   property $ \(Positive p) ->
 454   let (q0, q1) = linkOptimumAtPrice vs x0 x1 p in
 455   q1 `eq` (-p * q0)
 456
 457 prop_linkOptimumAtPrice_valid :: (Ord a, Show a)
 458   => ValueSimplex a Double -> Positive Double -> Property
 459 prop_linkOptimumAtPrice_valid vs (Positive p) =
 460   with2ArbitraryNodes vs $ \x0 x1 ->
 461   let
 462     (q0, q1) = linkOptimumAtPrice vs x0 x1 p
 463     s = vsLookup vs
 464   in
 465   q0 > - s x0 x1 && q1 > - s x1 x0
 466
 467 prop_linkOptimumAtPrice_correct_sign :: (Ord a, Show a)
 468   => ValueSimplex a Double -> Positive Double -> Property
 469 prop_linkOptimumAtPrice_correct_sign vs (Positive p) =
 470   with2ArbitraryNodes vs $ \x0 x1 ->
 471   compare p (price vs x0 x1)
 472   == compare 0 (fst $ linkOptimumAtPrice vs x0 x1 p)
 473
 474 prop_multiUpdate_linkOptimumAtPrice_improving :: (Ord a, Show a)
 475   => ValueSimplex a Double -> Property
 476 prop_multiUpdate_linkOptimumAtPrice_improving vs =
 477   generated_multiUpdate_improving vs distinctPairs $ \x0 x1 -> do
 478     p <- arbitrary `suchThat` (>= price vs x0 x1)
 479     return $ linkOptimumAtPrice vs x0 x1 p
 480
 481 arbitrarilyMultiUpdatedWithLinkOptimumAtNearPrice ::
 482   (Ord a, Ord b, Fractional b, MatrixElement b)
 483   => ValueSimplex a b -> Gen (ValueSimplex a b)
 484 arbitrarilyMultiUpdatedWithLinkOptimumAtNearPrice vs = do
 485   let xs = nodes vs
 486   xxs <- arbitrarySubset $ distinctPairs xs
 487   return $ multiUpdateWithAdjustmentList vs $ concat $ flip map (Set.toList xxs)
 488     $ \(x0, x1) ->
 489       let
 490         p = 1.01 * price vs x0 x1
 491         (q0, q1) = linkOptimumAtPrice vs x0 x1 p
 492       in
 493       [(x0, q0), (x1, q1)]
 494
 495 prop_multiUpdate_linkOptimumAtNearPrice_longrun_validity ::
 496   (Ord a, Show a)
 497   => ValueSimplex a Double -> Property
 498 prop_multiUpdate_linkOptimumAtNearPrice_longrun_validity =
 499   longrun_validity arbitrarilyMultiUpdatedWithLinkOptimumAtNearPrice
 500
 501 --------------------------------------------------------------------------------
 502
 503 prop_totalValue_correct :: Property
 504 prop_totalValue_correct = approx_Double_exact_Rational $ \eq vs ->
 505   withArbitraryNode vs $ \x ->
 506   totalValue vs x
 507   `eq` Set.foldr ((+) . (\y -> nodeValue vs y * price vs y x)) 0 (nodes vs)
 508
 509 arbitraryFractionalBetween0and1 :: Fractional a => Gen a
 510 arbitraryFractionalBetween0and1 = let precision = 9999999999999 in
 511   do
 512     b <- choose (2, precision)
 513     a <- choose (1, b - 1)
 514     return $ fromRational $ a % b
 515
 516 withArbitraryAddNodeParameters ::
 517   ( Arbitrary a, Ord a, Show a
 518   , Arbitrary b, Ord b, Fractional b, Show b
 519   , Testable p
 520   )
 521   => ValueSimplex a b -> (a -> b -> a -> b -> p) -> Property
 522 withArbitraryAddNodeParameters vs test =
 523   property $ \x ->
 524   Set.notMember x (nodes vs) ==>
 525   property $ \(Positive q) ->
 526   withArbitraryNode vs $ \y ->
 527   forAll arbitraryFractionalBetween0and1 $ \r ->
 528   test x q y $ r * totalValue vs y / q
 529
 530 withArbitrarilyAddNodedValueSimplex ::
 531   ( Arbitrary a, Ord a, Show a
 532   , Arbitrary b, Ord b, Fractional b, Show b
 533   , Testable p
 534   )
 535   => ValueSimplex a b -> (ValueSimplex a b -> p) -> Property
 536 withArbitrarilyAddNodedValueSimplex vs test =
 537   withArbitraryAddNodeParameters vs $ test .... addNode vs
 538
 539 testArbitrarilyAddNodedValueSimplex ::
 540   ( Arbitrary a, Ord a, Show a
 541   , Arbitrary b, Ord b, Fractional b, Show b
 542   , Testable p
 543   )
 544   => (ValueSimplex a b -> p) -> ValueSimplex a b -> Property
 545 testArbitrarilyAddNodedValueSimplex = flip withArbitrarilyAddNodedValueSimplex
 546
 547 prop_addNode_exact_validity_tests :: (Arbitrary a, Ord a, Show a)
 548   => ValueSimplex a Double -> Property
 549 prop_addNode_exact_validity_tests =
 550   testArbitrarilyAddNodedValueSimplex exact_ValueSimplex_validity_tests
 551
 552 prop_addNode_approx_validity_tests :: Property
 553 prop_addNode_approx_validity_tests =
 554   approx_Double_exact_Rational $
 555   testArbitrarilyAddNodedValueSimplex . approx_ValueSimplex_validity_tests
 556
 557 prop_addNode_nodes :: (Arbitrary a, Ord a, Show a)
 558   => ValueSimplex a Double -> Property
 559 prop_addNode_nodes vs = withArbitraryAddNodeParameters vs $ \x q y p ->
 560   nodes (addNode vs x q y p) == Set.insert x (nodes vs)
 561
 562 prop_addNode_nodeValue :: Property
 563 prop_addNode_nodeValue = approx_Double_exact_Rational $ \eq vs ->
 564   withArbitraryAddNodeParameters vs $ \x q y p ->
 565   nodeValue (addNode vs x q y p) x `eq` q
 566
 567 prop_addNode_price :: Property
 568 prop_addNode_price =
 569   approx_Double_exact_Rational $ \eq vs ->
 570   withArbitraryAddNodeParameters vs $ \x q y p ->
 571   price (addNode vs x q y p) x y `eq` p
 572
 573 prop_addNode_nodeValue_unchanged :: Property
 574 prop_addNode_nodeValue_unchanged =
 575   approx_Double_exact_Rational $ \eq vs ->
 576   withArbitrarilyAddNodedValueSimplex vs $ \vs' ->
 577   withArbitraryNode vs $ \i ->
 578   nodeValue vs' i `eq` nodeValue vs i
 579
 580 prop_addNode_price_unchanged :: Property
 581 prop_addNode_price_unchanged =
 582   approx_Double_exact_Rational $ \eq vs ->
 583   withArbitrarilyAddNodedValueSimplex vs $ \vs' ->
 584   with2ArbitraryNodes vs $ \i j ->
 585   price vs' i j `eq` price vs i j
 586
 587 prop_addNode_proportions_unchanged :: Property
 588 prop_addNode_proportions_unchanged =
 589   approx_Double_exact_Rational $ \eq vs ->
 590   let ss = linkValueSquared vs in
 591   withArbitrarilyAddNodedValueSimplex vs $ \vs' ->
 592   let ss' = linkValueSquared vs' in
 593   with2ArbitraryNodes vs $ \i j ->
 594   with2ArbitraryNodes vs $ \k l ->
 595   (ss' i j / ss' k l) `eq` (ss i j / ss k l)
 596
 597 --------------------------------------------------------------------------------
 598
 599 prop_strictlySuperior_irreflexive :: Property
 600 prop_strictlySuperior_irreflexive =
 601   approx_Double_exact_Rational $ \eq vs ->
 602   not $ strictlySuperior eq vs vs
 603
 604 prop_multiUpdate_strictlySuperior_one_way :: Property
 605 prop_multiUpdate_strictlySuperior_one_way =
 606   approx_Double_exact_Rational $ \eq vs ->
 607   property $ \(Blind f) ->
 608   let vs' = multiUpdate vs $ getPositive . f in
 609   not (liftEquivToValueSimplex eq vs vs') ==>
 610   strictlySuperior eq vs vs' == not (strictlySuperior eq vs' vs)
 611
 612 prop_multiUpdate_linkOptimumAtNearPrice_strictlySuperior :: Property
 613 prop_multiUpdate_linkOptimumAtNearPrice_strictlySuperior =
 614   approx_Double_exact_Rational $ \eq vs -> property $ do
 615   vs' <- arbitrarilyMultiUpdatedWithLinkOptimumAtNearPrice vs
 616   return $ not (liftEquivToValueSimplex eq vs vs') ==>
 617     strictlySuperior eq vs' vs
 618
 619 --------------------------------------------------------------------------------
 620
 621 arbitraryDepositFunction :: (CoArbitrary a, Ord a, Arbitrary b, Ord b, Num b)
 622   => ValueSimplex a b -> Gen (a -> b)
 623 arbitraryDepositFunction vs = do
 624   xs <- arbitrarySubset $ nodes vs
 625   f <- (getPositive .) <$> arbitrary
 626   return $ \x ->
 627     if Set.member x xs
 628       then nodeValue vs x + f x
 629       else nodeValue vs x
 630
 631 arbitrarilyDeposited ::
 632   (CoArbitrary a, Ord a)
 633   => ValueSimplex a Double -> Gen (ValueSimplex a Double)
 634 arbitrarilyDeposited vs = deposit vs <$> arbitraryDepositFunction vs
 635
 636 prop_arbitrarilyDeposited_validity_tests :: (CoArbitrary a, Ord a, Show a)
 637   => ValueSimplex a Double -> Property
 638 prop_arbitrarilyDeposited_validity_tests vs = do
 639   vs' <- arbitrarilyDeposited vs
 640   exact_ValueSimplex_validity_tests vs'
 641     .&&. approx_ValueSimplex_validity_tests (~~=) vs'
 642
 643 prop_arbitrarilyDeposited_nodes_unchanged :: (CoArbitrary a, Ord a)
 644   => ValueSimplex a Double -> Property
 645 prop_arbitrarilyDeposited_nodes_unchanged vs = property $
 646   (nodes vs ==) . nodes <$> arbitrarilyDeposited vs
 647
 648 prop_deposit_nodeValue :: (CoArbitrary a, Ord a, Show a)
 649   => ValueSimplex a Double -> Property
 650 prop_deposit_nodeValue vs = do
 651   f <- arbitraryDepositFunction vs
 652   withArbitraryNode vs $ \x -> nodeValue (deposit vs f) x ~~= f x
 653
 654 prop_deposit_valueEvenly :: (CoArbitrary a, Ord a, Show a)
 655   => ValueSimplex a Double -> Property
 656 prop_deposit_valueEvenly vs = do
 657   let v = halfLinkValue vs
 658   v' <- halfLinkValue <$> arbitrarilyDeposited vs
 659   with2ArbitraryNodes vs $ \x y -> with2ArbitraryNodes vs $ \z w ->
 660     (v' x y - v x y) * hybridPrice vs x y x
 661     ~~= (v' z w - v z w) * hybridPrice vs z w x
 662
 663 --------------------------------------------------------------------------------
 664
 665 return []
 666 allValueSimplexTests :: IO Bool
 667 allValueSimplexTests = $(quickCheckAll)
 668