ValueSimplex.hs

   1 module ValueSimplex where
   2 import Control.Applicative ((<$>), (<*>))
   3 import Data.Map (Map)
   4 import qualified Data.Map.Lazy as Map
   5 import Data.Maybe (fromMaybe)
   6 import Data.Set (Set)
   7 import qualified Data.Set as Set
   8 import Data.Tuple (swap)
   9 import Util.Function ((...))
  10 import Util.Set (allSet, anySet)
  11
  12 newtype ValueSimplex a b = VS {vsMap :: Map (a, a) b} deriving (Eq, Show)
  13
  14 data VSStatus
  15   = OK
  16   | WrongPairs
  17   | NonPositive
  18   | CyclesWrong
  19   | Empty
  20   deriving (Show, Eq)
  21
  22 nodes :: Ord a => ValueSimplex a b -> Set a
  23 nodes vs = Set.map fst $ Map.keysSet $ vsMap vs
  24
  25 pairUp :: a -> b -> (a, b)
  26 pairUp = curry id
  27
  28 distinctPairsOneWay :: Ord a => Set a -> Set (a, a)
  29 distinctPairsOneWay xs =
  30   case Set.minView xs of
  31     Nothing -> Set.empty
  32     Just (x, xs') -> Set.union
  33       (distinctPairsOneWay xs') $
  34       Set.map (pairUp x) xs'
  35
  36 distinctPairs :: Ord a => Set a -> Set (a, a)
  37 distinctPairs xs =
  38   let dpow = distinctPairsOneWay xs in
  39   Set.union dpow $ Set.map swap dpow
  40
  41 vsLookupMaybe :: Ord a => ValueSimplex a b -> a -> a -> Maybe b
  42 vsLookupMaybe vs x y = Map.lookup (x, y) $ vsMap vs
  43
  44 vsLookup :: (Ord a, Num b) => ValueSimplex a b -> a -> a -> b
  45 vsLookup = fromMaybe 0 ... vsLookupMaybe
  46
  47 fromFunction :: Ord a => (a -> a -> b) -> Set a -> ValueSimplex a b
  48 fromFunction f xs = VS $ Map.fromSet (uncurry f) $ distinctPairs xs
  49
  50 validTriangle :: (Ord a, Num b) =>
  51   (b -> b -> Bool) -> ValueSimplex a b -> a -> a -> a -> Bool
  52 validTriangle eq vs x y z =
  53   (vsLookup vs x y * vsLookup vs y z * vsLookup vs z x)
  54   `eq` (vsLookup vs z y * vsLookup vs y x * vsLookup vs x z)
  55
  56 status :: (Ord a, Ord b, Num b) =>
  57   (b -> b -> Bool) -> ValueSimplex a b -> VSStatus
  58 status eq vs =
  59   let dPairs = distinctPairs $ nodes vs in
  60   if Map.keysSet (vsMap vs) /= dPairs
  61   then WrongPairs
  62   else if anySet ((<= 0) . (uncurry $ vsLookup vs)) dPairs
  63   then NonPositive
  64   else
  65   case Set.minView $ nodes vs of
  66     Nothing -> Empty
  67     Just (x, xs) ->
  68       if allSet (uncurry $ validTriangle eq vs x) $ distinctPairsOneWay xs
  69       then OK
  70       else CyclesWrong
  71
  72 -- price vs x y is the number of ys required to equal one x in value, according
  73 -- to the internal state of the ValueSimplex vs
  74 price :: (Ord a, Fractional b) => ValueSimplex a b -> a -> a -> Maybe b
  75 price vs x y = (/) <$> vsLookupMaybe vs y x <*> vsLookupMaybe vs x y
  76