Switch to Scientific-math

7 files changed, 176 insertions, 96 deletions

diff --git a/package.yaml b/package.yaml
new file mode 100644
index 0000000..123fe83
--- /dev/null
+++ b/package.yaml
@@ -0,0 +1,49 @@
+name: trivmix
+version: 4.0.0
+license: PublicDomain
+license-file: LICENSE
+author: Gregor Kleen <aethoago@141.li>
+category: Sound
+build-type: Simple
+git: https://git.yggdrasil.li/gkleen/pub/trivmix
+
+library:
+  source-dirs: src
+  exposed-modules: Trivmix.Types
+  dependencies:
+    - base >=4.8 && <5
+    - data-default >=0.5 && <1
+    - case-insensitive >=1.2 && <2
+    - refined >=0.1.2.1 && <1
+    - scientific >=0.3.6.2 && <1
+    - th-lift >=0.7.10 && <1
+
+executables:
+  trivmix:
+    main: Trivmix.hs
+    source-dirs: trivmix
+    dependencies:
+      - base >=4.8 && <5
+      - jack >=0.7 && <1
+      - optparse-applicative >=0.11 && <1
+      - directory >=1.2 && <2
+      - filepath >=1.3 && <2
+      - unix >=2.7 && <3
+      - hinotify >=0.3 && <1
+      - transformers >=0.3 && <1
+      - explicit-exception >=0.1 && <1
+      - process >=1.2 && <2
+      - filelock >=0.1 && <1
+      - systemd >=1.1.2 && <2
+      - heredoc >=0.2.0.0 && <1
+      - refined >=0.1.2.1 && <1
+      - trivmix
+  adjmix:
+    main: Adjmix.hs
+    source-dirs: adjmix
+    dependencies:
+      - base >=4.8 && <5
+      - optparse-applicative >=0.11 && <1
+      - filepath >=1.3 && <2
+      - filelock >=0.1 && <1
+      - trivmix
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
diff --git a/trivmix.cabal b/trivmix.cabal
index 0cbccdb..962edd6 100644
--- a/trivmix.cabal
+++ b/trivmix.cabal
@@ -1,58 +1,67 @@
--- Initial trivmix.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
+name:           trivmix
+version:        4.0.0
+category:       Sound
+author:         Gregor Kleen <aethoago@141.li>
+license:        PublicDomain
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
 
-name:                trivmix
-version:             3.3.2
--- synopsis:            
--- description:         
-license:             PublicDomain
-license-file:        LICENSE
-author:              Gregor Kleen
-maintainer:          aethoago@141.li
--- copyright:           
-category:            Sound
-build-type:          Simple
--- extra-source-files:  
-cabal-version:       >=1.10
+source-repository head
+  type: git
+  location: https://git.yggdrasil.li/gkleen/pub/trivmix
 
 library
-  hs-source-dirs:      src
-  default-language:    Haskell2010
-  exposed-modules:     Trivmix.Types
-  build-depends:       base >=4.8 && <5
-                     , data-default >=0.5 && <1
-                     , case-insensitive >=1.2 && <2
-                     , refined >=0.1.2.1 && <1
-
-executable trivmix
-  main-is:             Trivmix.hs
-  -- other-modules:       
-  -- other-extensions:    
-  build-depends:       base >=4.8 && <5
-                     , jack >=0.7 && <1
-                     , optparse-applicative >=0.11 && <1
-                     , directory >=1.2 && <2
-                     , filepath >=1.3 && <2
-                     , unix >=2.7 && <3
-                     , hinotify >=0.3 && <1
-                     , transformers >=0.3 && <1
-                     , explicit-exception >=0.1 && <1
-                     , process >=1.2 && <2
-                     , filelock >=0.1 && <1
-                     , systemd >=1.1.2 && <2
-                     , heredoc >=0.2.0.0 && <1
-                     , refined >=0.1.2.1 && <1
-                     , trivmix
-  hs-source-dirs:      trivmix
-  default-language:    Haskell2010
-  ghc-options:         -threaded
+  exposed-modules:
+      Trivmix.Types
+  other-modules:
+      Data.Scientific.Lift
+      Paths_trivmix
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.8 && <5
+    , case-insensitive >=1.2 && <2
+    , data-default >=0.5 && <1
+    , refined >=0.1.2.1 && <1
+    , scientific >=0.3.6.2 && <1
+    , th-lift >=0.7.10 && <1
+  default-language: Haskell2010
 
 executable adjmix
-  main-is:             Adjmix.hs
-  build-depends:       base >=4.8 && <5
-                     , optparse-applicative >=0.11 && <1
-                     , filepath >=1.3 && <2
-                     , filelock >=0.1 && <1
-                     , trivmix
-  hs-source-dirs:      adjmix
-  default-language:    Haskell2010
+  main-is: Adjmix.hs
+  other-modules:
+      Paths_trivmix
+  hs-source-dirs:
+      adjmix
+  build-depends:
+      base >=4.8 && <5
+    , filelock >=0.1 && <1
+    , filepath >=1.3 && <2
+    , optparse-applicative >=0.11 && <1
+    , trivmix
+  default-language: Haskell2010
+
+executable trivmix
+  main-is: Trivmix.hs
+  other-modules:
+      Paths_trivmix
+  hs-source-dirs:
+      trivmix
+  build-depends:
+      base >=4.8 && <5
+    , directory >=1.2 && <2
+    , explicit-exception >=0.1 && <1
+    , filelock >=0.1 && <1
+    , filepath >=1.3 && <2
+    , heredoc >=0.2.0.0 && <1
+    , hinotify >=0.3 && <1
+    , jack >=0.7 && <1
+    , optparse-applicative >=0.11 && <1
+    , process >=1.2 && <2
+    , refined >=0.1.2.1 && <1
+    , systemd >=1.1.2 && <2
+    , transformers >=0.3 && <1
+    , trivmix
+    , unix >=2.7 && <3
+  default-language: Haskell2010
diff --git a/trivmix.cabal.gup b/trivmix.cabal.gup
new file mode 100644
index 0000000..51bcecc
--- /dev/null
+++ b/trivmix.cabal.gup
@@ -0,0 +1,4 @@
+#!/usr/bin/env zsh
+
+gup -u ${2:h}/package.yaml
+hpack ${2:h}/package.yaml - >! ${1}
\ No newline at end of file
diff --git a/trivmix.nix b/trivmix.nix
index be84746..bcc7037 100644
--- a/trivmix.nix
+++ b/trivmix.nix
@@ -1,16 +1,16 @@
 { mkDerivation, base, case-insensitive, data-default, directory
 , explicit-exception, filelock, filepath, heredoc, hinotify, jack
-, optparse-applicative, process, refined, stdenv, systemd
-, transformers, unix
+, optparse-applicative, process, refined, scientific, stdenv
+, systemd, th-lift, transformers, unix
 }:
 mkDerivation {
   pname = "trivmix";
-  version = "3.3.2";
+  version = "4.0.0";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base case-insensitive data-default refined
+    base case-insensitive data-default refined scientific th-lift
   ];
   executableHaskellDepends = [
     base directory explicit-exception filelock filepath heredoc
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index b2d87ec..5cddf6f 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -43,8 +43,9 @@ import Control.Monad
 
 import Text.Heredoc (str)
 
-import Refined (refine)
+import Refined
   
+import Data.Scientific
 import Trivmix.Types
 
 data Options = Options
@@ -53,7 +54,7 @@ data Options = Options
                , client :: String
                , initialLevel :: Level
                , initialBalance :: Balance
-               , fps, interval :: Float
+               , fps, interval, watchdogInterval :: Scientific
                , run :: [FilePath]
                , balanceFiles :: [FilePath]
                , levelFiles :: [FilePath]
@@ -101,6 +102,12 @@ optionParser = Options
                               <> value 0.2
                               <> showDefault
                                )
+               <*> option auto ( long "watchdog"
+                              <> metavar "NUMBER"
+                              <> help "Signal watchdog every ’NUMBER’ seconds"
+                              <> value 1
+                              <> showDefault
+                               )
                <*> many ( strOption ( long "run"
                                    <> metavar "FILE"
                                    <> help [str|Execute a file once setup of jacks is done (use this to autoconnect)
@@ -183,18 +190,16 @@ trivmix Options{..} = do
               frames = interval * fps
               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 (bToFloat -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
+              linInt' x a b = either error id $ asScientific (linInt x) a b
+              mulBalance (bToScientific -> b) x = either error id $ asScientific (*) (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]
+            currentLevel <- (\(CFloat f) -> Lin . either error id . refine $ realToFrac f) <$> readMVar level'
+            mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0)
           notifyReady
-          forever $ threadDelay 1000000 >> notifyWatchdog
+          forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog
 
-mix :: MVar Level -> CFloat -> IO CFloat
-mix level input = do
-  level' <- readMVar level
-  return $ (CFloat $ toFloat level') * input
+mix :: MVar CFloat -> CFloat -> IO CFloat
+mix level input = (input *) <$> readMVar level
 
 handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO ()
 handleFiles inotify level files = do