Added adjmix

1 files changed, 90 insertions, 0 deletions

diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
new file mode 100644
index 0000000..66accdf
--- /dev/null
+++ b/src/Trivmix/Types.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+
+module Trivmix.Types
+       ( Level
+       , toFloat
+       , Adjustment(..)
+       , doAdjustment
+       , module Data.Default
+       ) where
+
+import Data.Fixed
+import           Data.CaseInsensitive  ( CI )
+import qualified Data.CaseInsensitive as CI
+
+import Data.Default
+
+import Data.Function (on)
+
+data Level = Lin Float | DB Float
+
+instance Num Level where
+  (+) = asFloat (+)
+  (-) = asFloat (-)
+  (*) = asFloat (*)
+  abs = Lin . abs . toFloat
+  signum = Lin . signum . toFloat
+  fromInteger = Lin . fromInteger
+
+asFloat :: (Float -> Float -> Float) -> Level -> Level -> Level
+asFloat f (Lin x) (Lin y) = Lin $ f x y
+asFloat f x y = DB $ (f `on` toFloat) x y
+
+toFloat :: Level -> Float
+toFloat (Lin x) = x
+toFloat (DB x) = x
+
+withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
+withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
+
+withType :: (p a -> f a) -> f a
+withType f = f undefined
+
+withResolution :: (HasResolution a) => (Integer -> f a) -> f a
+withResolution f = withType (f . resolution)
+
+instance Show Level where
+  show (Lin x) = show x
+  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
+    where
+      x' = 20 * (logBase 10 x)
+
+instance Read Level where
+  readsPrec i = map toL . readsPrec i
+    where
+      toL :: (Float, String) -> (Level, String)
+      toL (f, str)
+        | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
+        | otherwise = (Lin f, str)
+        where
+          prec = take lU str
+          rest = drop lU str
+          unit = "dB"
+          lU = length unit
+
+instance Eq Level where
+  (Lin a) == (Lin b) = a == b
+  (Lin a) == (DB b) = a == b
+  (DB a) == (Lin b) = a == b
+  (DB a) == (DB b) = a == b
+
+instance Default Level where
+  def = Lin 0
+
+data Adjustment a = Set a
+                  | Add a
+                  | Sub a
+                  deriving (Show, Eq)
+
+class Adjustable a where
+  add :: a -> a -> a
+  sub :: a -> a -> a
+
+instance Num a => Adjustable a where
+  add = (+)
+  sub = (-)
+
+doAdjustment :: Adjustable a => a -> Adjustment a -> a
+doAdjustment _ (Set y) = y
+doAdjustment x (Add y) = add x y
+doAdjustment x (Sub y) = sub x y