Fix handling of Balance

4 files changed, 48 insertions, 8 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
diff --git a/trivmix.cabal b/trivmix.cabal
index e39d451..e12ea00 100644
--- a/trivmix.cabal
+++ b/trivmix.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                trivmix
-version:             3.1.1
+version:             3.1.2
 -- synopsis:            
 -- description:         
 license:             PublicDomain
diff --git a/trivmix.nix b/trivmix.nix
index d77a0ee..416c55d 100644
--- a/trivmix.nix
+++ b/trivmix.nix
@@ -5,7 +5,7 @@
 }:
 mkDerivation {
   pname = "trivmix";
-  version = "3.1.1";
+  version = "3.1.2";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index 7743246..2e05b13 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -42,12 +42,11 @@ import Data.Function
 import Control.Monad
 
 import Text.Heredoc (str)
-import Refined
+
+import Refined (refine)
   
 import Trivmix.Types
 
-type Balance = Refined ZeroToOne Float
-  
 data Options = Options
                { input :: String
                , output :: String
@@ -86,7 +85,7 @@ optionParser = Options
                <*> option auto ( long "initial-balance"
                               <> metavar "BALANCE"
                               <> help "Initial value for balance"
-                              <> value ($$(refineTH 1.0) :: Balance)
+                              <> value def
                               <> showDefault
                                )
                <*> many ( strOption ( long "run"
@@ -161,7 +160,7 @@ trivmix Options{..} = do
       delay = round $ recip fps * 1e6
       linInt x a b = a * (1 - x) + b * x
       linInt' x a b = either error id $ asFloat (linInt x) a b
-      mulBalance (unrefine -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
+      mulBalance (bToFloat -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
     newLevel <- mulBalance <$> readMVar balance <*> readMVar level
     currentLevel <- readMVar level'
     mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])