From 86ce943d5a49982246ab83e4acc72ffb7c22567c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 15 May 2018 12:50:42 +0200 Subject: Implement balance & refine types --- src/Trivmix/Types.hs | 79 ++++++++++++++++++++++++++++------------------------ trivmix.cabal | 5 +++- trivmix.nix | 17 ++++++----- trivmix/Trivmix.hs | 54 ++++++++++++++++++++++++++++------- 4 files changed, 100 insertions(+), 55 deletions(-) diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs index a6a41b9..f01e023 100644 --- a/src/Trivmix/Types.hs +++ b/src/Trivmix/Types.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-} module Trivmix.Types - ( Level + ( Level' + , Level(Lin), toLin , toFloat , asFloat , Adjustment(..) @@ -13,27 +14,37 @@ import Data.Fixed import Data.CaseInsensitive ( CI ) import qualified Data.CaseInsensitive as CI +import Text.ParserCombinators.ReadPrec +import Control.Applicative +import Control.Monad + import Data.Default import Data.Function (on) -data Level = Lin Float | DB Float +import Refined -instance Num Level where - (+) = asFloat (+) - (-) = asFloat (-) - (*) = asFloat (*) - abs = Lin . abs . toFloat - signum = Lin . signum . toFloat - fromInteger = Lin . fromInteger +type Level' = Refined NonNegative Float +data Level = Lin { toLin :: Level' } | DB { toLin :: Level' } -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 +instance Num Level where + (+) = fmap (either error id) . asFloat (+) + (-) = fmap (either error id) . asFloat (-) + (*) = fmap (either error id) . asFloat (*) + abs = Lin . toLin + signum = Lin . either error id . refine . signum . toFloat + 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) + where + toLvl + | DB _ <- x = DB + | DB _ <- y = DB + | otherwise = Lin toFloat :: Level -> Float -toFloat (Lin x) = x -toFloat (DB x) = x +toFloat = unrefine . toLin withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p') @@ -44,39 +55,33 @@ withType f = f undefined withResolution :: (HasResolution a) => (Integer -> f a) -> f a withResolution f = withType (f . resolution) -linToDb :: Float -> Float -linToDb x = 20 * (logBase 10 x) +linToDb :: Level' -> Float +linToDb (unrefine -> x) = 20 * (logBase 10 x) -dBToLin :: Float -> Float -dBToLin x = 10 ** (0.05 * x) +dBToLin :: Float -> Level' +dBToLin x = either error id . refine $ 10 ** (0.05 * x) instance Show Level where show (Lin x) = show x - show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB" - where - x' = linToDb x + show (DB (linToDb -> x)) = (show $ (withPrec x :: Milli)) ++ "dB" instance Read Level where - readsPrec i = map toL . readsPrec i + readsPrec = readPrec_to_S $ parseDb <|> parseLin where - toL :: (Float, String) -> (Level, String) - toL (f, str) - | ((==) `on` CI.mk) prec unit = (DB $ dBToLin f, rest) - | otherwise = (Lin f, str) - where - prec = take lU str - rest = drop lU str - unit = "dB" - lU = length unit + parseDb = do + db <- readS_to_Prec readsPrec + let + unit@(length -> lU) = "dB" + unit' <- forM [1..lU] $ const get + guard $ ((==) `on` CI.mk) unit unit' + return . DB $ dBToLin db + parseLin = Lin <$> readS_to_Prec readsPrec 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 + (==) = (==) `on` toLin instance Default Level where - def = Lin 0 + def = Lin $$(refineTH 0) data Adjustment a = Set a | Add a diff --git a/trivmix.cabal b/trivmix.cabal index 1a2ef21..d075871 100644 --- a/trivmix.cabal +++ b/trivmix.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: trivmix -version: 2.7.6 +version: 3.0.0 -- synopsis: -- description: license: PublicDomain @@ -22,6 +22,7 @@ library 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 @@ -39,6 +40,8 @@ executable trivmix , 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 diff --git a/trivmix.nix b/trivmix.nix index dcc06c0..a823793 100644 --- a/trivmix.nix +++ b/trivmix.nix @@ -1,18 +1,21 @@ { mkDerivation, base, case-insensitive, data-default, directory -, explicit-exception, filelock, filepath, hinotify, jack -, optparse-applicative, process, stdenv, systemd, transformers -, unix +, explicit-exception, filelock, filepath, heredoc, hinotify, jack +, optparse-applicative, process, refined, stdenv, systemd +, transformers, unix }: mkDerivation { pname = "trivmix"; - version = "2.7.6"; + version = "3.0.0"; src = ./.; isLibrary = true; isExecutable = true; - libraryHaskellDepends = [ base case-insensitive data-default ]; + libraryHaskellDepends = [ + base case-insensitive data-default refined + ]; executableHaskellDepends = [ - base directory explicit-exception filelock filepath hinotify jack - optparse-applicative process systemd transformers unix + base directory explicit-exception filelock filepath heredoc + hinotify jack optparse-applicative process refined systemd + transformers unix ]; license = stdenv.lib.licenses.publicDomain; } diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs index 084da7f..4d7c6f7 100644 --- a/trivmix/Trivmix.hs +++ b/trivmix/Trivmix.hs @@ -1,10 +1,12 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} import Foreign.C.Types (CFloat(..)) import qualified Sound.JACK as Jack import qualified Sound.JACK.Audio as Audio -import Options.Applicative +import Options.Applicative hiding (str) import Data.Maybe @@ -16,7 +18,7 @@ import System.Posix.Types import System.Environment import System.Process -import System.Systemd.Daemon (notifyReady) +import System.Systemd.Daemon (notifyReady, notifyWatchdog) import Control.Concurrent import Control.Concurrent.MVar @@ -38,15 +40,22 @@ import Data.Char import Data.Function import Control.Monad + +import Text.Heredoc (str) +import Refined import Trivmix.Types +type Balance = Refined ZeroToOne Float + data Options = Options { input :: String , output :: String , client :: String , initialLevel :: Level + , initialBalance :: Balance , run :: [FilePath] + , balanceFiles :: [FilePath] , levelFiles :: [FilePath] } @@ -74,13 +83,33 @@ optionParser = Options <> value def <> showDefault ) + <*> option auto ( long "balance" + <> metavar "BALANCE" + <> help "Initial value for balance" + <> value ($$(refineTH 1.0) :: Balance) + <> showDefault + ) <*> many ( strOption ( long "run" <> metavar "FILE" - <> help "Execute a file once setup of jacks is done (use this to autoconnect)\nThe executable gets passed the input port (including client name) as its first argument and the output as its second." + <> help [str|Execute a file once setup of jacks is done (use this to autoconnect) + |The executable gets passed the input port (including client name) as its first argument and the output as its second. + |] ) ) + <*> many ( strOption ( long "balance" + <> metavar "FILE" + <> help [str|Files that contain factors in the interval [0,1] to multiply with each other and the current level. + |For deterministic behaviour use flock(2). + |The format used in these files is a float using ‘.’ as a decimal point. + |] + ) + ) <*> many (strArgument ( metavar "FILE..." - <> help "Files that contain levels to assume and synchronize\nFor deterministic behaviour use flock(2).\nThe format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’.\nCaveat: ‘-InfinitydB’ exists and works as expected (i.e.: it is equal to ‘0.0’)" + <> help [str|Files that contain levels to assume and synchronize + |For deterministic behaviour use flock(2). + |The format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’. + |Caveat: ‘-InfinitydB’ exists and works as expected (i.e.: it is equal to ‘0.0’) + |] ) ) @@ -122,6 +151,7 @@ main = execParser opts >>= trivmix trivmix :: Options -> IO () trivmix Options{..} = do level <- newMVar initialLevel + balance <- newMVar initialBalance level' <- newMVar initialLevel forkIO $ forever $ do -- Smooth out discontinuity let @@ -130,12 +160,15 @@ trivmix Options{..} = do frames = interval * fps delay = round $ recip fps * 1e6 linInt x a b = a * (1 - x) + b * x - newLevel <- readMVar level + 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 + newLevel <- mulBalance <$> readMVar balance <*> readMVar level currentLevel <- readMVar level' - mapM_ (\x -> swapMVar level' (asFloat (linInt x) currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float]) + mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float]) let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles withFiles $ withINotify $ \inotify -> do handleFiles inotify level levelFiles + handleFiles inotify balance levelFiles Jack.handleExceptions $ Jack.withClientDefault client $ \client' -> Jack.withPort client' input $ \input' -> @@ -149,13 +182,14 @@ trivmix Options{..} = do mix :: MVar Level -> CFloat -> IO CFloat mix level input = do + notifyWatchdog level' <- readMVar level return $ (CFloat $ toFloat level') * input -handleFiles :: INotify -> MVar Level -> [FilePath] -> IO () +handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO () handleFiles inotify level files = do initLevel <- readMVar level - levelChanges <- (newChan :: IO (Chan Level)) + levelChanges <- newChan stderrLock <- newEmptyMVar let handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock) @@ -206,7 +240,7 @@ takeWhileM pred (x:xs) = do False -> do return [] -readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO () +readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> MVar () -> IO () readLevel levelChan current file stderrLock = catch action handler where action = do @@ -228,7 +262,7 @@ readLevel levelChan current file stderrLock = catch action handler then stripSpace' xs else l -writeLevel :: FilePath -> MVar () -> Level -> IO () +writeLevel :: Show l => FilePath -> MVar () -> l -> IO () writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do withMVarLock stderrLock $ hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" -- cgit v1.2.3