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 --- trivmix/Trivmix.hs | 54 ++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 10 deletions(-) (limited to 'trivmix') 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