From 879e0c7218298349b9c92e9d3362830c371ec78e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 15 May 2018 21:21:48 +0200 Subject: Switch to Scientific-math --- package.yaml | 49 +++++++++++++++++++ src/Data/Scientific/Lift.hs | 9 ++++ src/Trivmix/Types.hs | 60 ++++++++++++----------- trivmix.cabal | 115 ++++++++++++++++++++++++-------------------- trivmix.cabal.gup | 4 ++ trivmix.nix | 8 +-- trivmix/Trivmix.hs | 27 ++++++----- 7 files changed, 176 insertions(+), 96 deletions(-) create mode 100644 package.yaml create mode 100644 src/Data/Scientific/Lift.hs create mode 100644 trivmix.cabal.gup 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 +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 +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 -- cgit v1.2.3