Switch to Scientific-math

2 files changed, 41 insertions, 28 deletions

diff --git a/src/Data/Scientific/Lift.hs b/src/Data/Scientific/Lift.hs
new file mode 100644
index 0000000..7d1a372
--- /dev/null
+++ b/src/Data/Scientific/Lift.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Scientific.Lift where
+
+import Data.Scientific (Scientific)
+import Language.Haskell.TH.Lift (deriveLift)
+
+deriveLift ''Scientific
diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index fe44a27..5e4660d 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -2,12 +2,12 @@
 
 module Trivmix.Types
        ( Level'
-       , Level(Lin), toLin
-       , toFloat
-       , asFloat
+       , Level(Lin, toLin)
+       , toScientific
+       , asScientific
        , Balance(..)
-       , bToFloat
-       , bAsFloat
+       , bToScientific
+       , bAsScientific
        , Adjustment(..)
        , doAdjustment
        , module Data.Default
@@ -27,27 +27,31 @@ import Data.Function (on)
 
 import Refined
 
-type Level' = Refined NonNegative Float
+import Data.Scientific
+import Data.Scientific.Lift
+
+
+type Level' = Refined NonNegative Scientific
 data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
 
 instance Num Level where
-  (+) = fmap (either error id) . asFloat (+)
-  (-) = fmap (either error id) . asFloat (-)
-  (*) = fmap (either error id) . asFloat (*)
+  (+) = fmap (either error id) . asScientific (+)
+  (-) = fmap (either error id) . asScientific (-)
+  (*) = fmap (either error id) . asScientific (*)
   abs = id
-  signum = Lin . either error id . refine . signum . toFloat
+  signum = Lin . either error id . refine . signum . toScientific
   fromInteger = Lin . either error id . refine . fromInteger
 
-asFloat :: (Float -> Float -> Float) -> Level -> Level -> Either String Level
-asFloat ((`on` toFloat) -> f) x y = toLvl <$> refine (f x y)
+asScientific :: (Scientific -> Scientific -> Scientific) -> Level -> Level -> Either String Level
+asScientific ((`on` toScientific) -> f) x y = toLvl <$> refine (f x y)
   where
     toLvl
       | DB _ <- x = DB
       | DB _ <- y = DB
       | otherwise = Lin
 
-toFloat :: Level -> Float
-toFloat = unrefine . toLin
+toScientific :: Level -> Scientific
+toScientific = unrefine . toLin
 
 withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
 withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
@@ -58,11 +62,11 @@ withType f = f undefined
 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
 withResolution f = withType (f . resolution)
 
-linToDb :: Level' -> Float
-linToDb (unrefine -> x) = 20 * (logBase 10 x)
+linToDb :: Level' -> Scientific
+linToDb (unrefine -> x) = realToFrac (20 * (logBase 10 $ toRealFloat x) :: Double)
 
-dBToLin :: Float -> Level'
-dBToLin x = either error id . refine $ 10 ** (0.05 * x)
+dBToLin :: Scientific -> Level'
+dBToLin x = either error id . refine . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)
 
 instance Show Level where
   show (Lin (unrefine -> x)) = show x
@@ -93,25 +97,25 @@ instance Default Level where
 
 
 
-newtype Balance = Balance { unBalance :: Refined ZeroToOne Float }
+newtype Balance = Balance { unBalance :: Refined ZeroToOne Scientific }
   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
+bAsScientific :: (Scientific -> Scientific -> Scientific) -> Balance -> Balance -> Either String Balance
+bAsScientific f (unrefine . unBalance -> x) (unrefine . unBalance -> y) = fmap Balance . refine $ f x y
 
-bToFloat :: Balance -> Float
-bToFloat = unrefine . unBalance
+bToScientific :: Balance -> Scientific
+bToScientific = unrefine . unBalance
 
 instance Num Balance where
-  (+) = fmap (either error id) . bAsFloat (+)
-  (-) = fmap (either error id) . bAsFloat (-)
-  (*) = fmap (either error id) . bAsFloat (*)
+  (+) = fmap (either error id) . bAsScientific (+)
+  (-) = fmap (either error id) . bAsScientific (-)
+  (*) = fmap (either error id) . bAsScientific (*)
   abs = id
-  signum = Balance . either error id . refine . signum . bToFloat
+  signum = Balance . either error id . refine . signum . bToScientific
   fromInteger = Balance . either error id . refine . fromInteger
 
 instance Show Balance where
-  show = show . bToFloat
+  show = show . bToScientific
   
 instance Read Balance where
   readsPrec = readPrec_to_S $ do