Test/ValueSimplex.hs

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