Fix handling of Balance

1 files changed, 42 insertions, 1 deletions

diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index abfdc43..fe44a27 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -5,6 +5,9 @@ module Trivmix.Types
        , Level(Lin), toLin
        , toFloat
        , asFloat
+       , Balance(..)
+       , bToFloat
+       , bAsFloat
        , Adjustment(..)
        , doAdjustment
        , module Data.Default
@@ -31,7 +34,7 @@ instance Num Level where
   (+) = fmap (either error id) . asFloat (+)
   (-) = fmap (either error id) . asFloat (-)
   (*) = fmap (either error id) . asFloat (*)
-  abs = Lin . toLin
+  abs = id
   signum = Lin . either error id . refine . signum . toFloat
   fromInteger = Lin . either error id . refine . fromInteger
 
@@ -82,9 +85,43 @@ instance Read Level where
 instance Eq Level where
   (==) = (==) `on` toLin
 
+instance Ord Level where
+  compare = compare `on` toLin
+
 instance Default Level where
   def = Lin $$(refineTH 0)
 
+
+
+newtype Balance = Balance { unBalance :: Refined ZeroToOne Float }
+  deriving (Ord, Eq)
+
+bAsFloat :: (Float -> Float -> Float) -> Balance -> Balance -> Either String Balance
+bAsFloat f (unrefine . unBalance -> x) (unrefine . unBalance -> y) = fmap Balance . refine $ f x y
+
+bToFloat :: Balance -> Float
+bToFloat = unrefine . unBalance
+
+instance Num Balance where
+  (+) = fmap (either error id) . bAsFloat (+)
+  (-) = fmap (either error id) . bAsFloat (-)
+  (*) = fmap (either error id) . bAsFloat (*)
+  abs = id
+  signum = Balance . either error id . refine . signum . bToFloat
+  fromInteger = Balance . either error id . refine . fromInteger
+
+instance Show Balance where
+  show = show . bToFloat
+  
+instance Read Balance where
+  readsPrec = readPrec_to_S $ do
+    b <- readS_to_Prec readsPrec
+    either (const mzero) (return . Balance) $ refine b
+
+instance Default Balance where
+  def = Balance $$(refineTH 1)
+  
+
 data Adjustment a = Set a
                   | Add a
                   | Sub a
@@ -104,6 +141,10 @@ instance Adjustable Level where
   sub (DB x) (DB y) = DB $ dBToLin $ ((-) `on` linToDb) x y
   sub x y = x - y
 
+instance Adjustable Balance where
+  add = (+)
+  sub = (-)
+
 doAdjustment :: Adjustable a => a -> Adjustment a -> a
 doAdjustment _ (Set y) = y
 doAdjustment x (Add y) = add x y