From 60cc6cf218d8f1a12360d0188450f83e04d92c1a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 9 Jun 2015 22:32:15 +0200 Subject: decibel levels && multiple level files --- src/Trivmix.hs | 133 +++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 96 insertions(+), 37 deletions(-) (limited to 'src/Trivmix.hs') diff --git a/src/Trivmix.hs b/src/Trivmix.hs index c1fbe8a..abb7c32 100644 --- a/src/Trivmix.hs +++ b/src/Trivmix.hs @@ -17,6 +17,7 @@ import System.Process import Control.Concurrent import Control.Concurrent.MVar +import Control.Concurrent.Chan import qualified Control.Monad.Trans.Class as Trans import qualified Control.Monad.Exception.Synchronous as Sync @@ -27,16 +28,40 @@ import System.IO.Error import System.INotify import Data.Char +import Data.Function + +import Control.Monad + +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI data Options = Options { input :: String , output :: String , client :: String , run :: Maybe String - , initialLevel :: Float - , stateDir :: FilePath + , levelFiles :: [FilePath] } +data Level = Lin Float | DB Float + +instance Show Level where + show (Lin x) = show x + show (DB x) = (show x) ++ "dB" + +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 f, rest) + | otherwise = (Lin f, str) + where + prec = take lU str + rest = drop lU str + unit = "dB" + lU = length unit + optionParser :: Parser Options optionParser = Options <$> (fromMaybe "in" <$> optional (strOption ( long "input" @@ -56,14 +81,24 @@ optionParser = Options <$> <> metavar "FILE" ) ) - <*> (fromMaybe 0 <$> optional (option auto ( long "level" - <> metavar "FLOAT" - ) - ) - ) - <*> strOption ( long "dir" - <> metavar "DIRECTORY" - ) + <*> some (strOption ( long "level" + <> metavar "FILE" + ) + ) + +initialLevel :: Level +initialLevel = Lin 0 + +watchedAttrs :: [EventVariety] +watchedAttrs = [ Modify + , Move + , MoveIn + , MoveOut + , MoveSelf + , Create + , Delete + , DeleteSelf + ] main :: IO () main = execParser opts >>= trivmix @@ -75,11 +110,10 @@ main = execParser opts >>= trivmix ) trivmix :: Options -> IO () -trivmix Options{..} = onDirectory stateDir $ do +trivmix Options{..} = do level <- newMVar initialLevel - let levelFile = stateDir "level" - onLevelFile levelFile initialLevel $ withINotify $ \n -> do - addWatch n [Modify] levelFile (const $ handleLevel level levelFile) + withINotify $ \inotify -> do + handleFiles inotify level levelFiles Jack.handleExceptions $ Jack.withClientDefault client $ \client' -> Jack.withPort client' input $ \input' -> @@ -93,42 +127,67 @@ trivmix Options{..} = onDirectory stateDir $ do Audio.withProcessMono client' input' (mix level) output' $ Jack.withActivation client' $ Trans.lift Jack.waitForBreak -onDirectory :: FilePath -> IO () -> IO () -onDirectory stateDir io = do - exists <- doesDirectoryExist stateDir - createDirectoryIfMissing True stateDir - finally io $ if exists then removeDirectory stateDir else return () - -mix :: MVar Float -> CFloat -> IO CFloat +mix :: MVar Level -> CFloat -> IO CFloat mix level input = do level' <- readMVar level - return $ (CFloat level') * input - -onLevelFile :: FilePath -> Float -> IO a -> IO a -onLevelFile file initial action = do + return $ (CFloat $ toFloat level') * input + where + toFloat (Lin x) = x + toFloat (DB x) = 10 ** (0.05 * x) + +handleFiles :: INotify -> MVar Level -> [FilePath] -> IO () +handleFiles inotify level files = do + initLevel <- readMVar level + levelChanges <- (newChan :: IO (Chan Level)) + let + handleFiles' = mapM handleFile files + handleFile file = do + levelChanges' <- dupChan levelChanges + forkIO $ forever $ do -- Broadcast level changes and update all files + readChan levelChanges' >>= writeLevel file + addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file) + foldl (.) id [onStateFile f (show initLevel ++ "\n") | f <- files] $ handleFiles' + forkIO $ forever $ do + readChan levelChanges >>= swapMVar level + return () + return () + +onStateFile :: FilePath -> String -> IO a -> IO a +onStateFile file initial action = do + let directory = takeDirectory file + dirExists <- doesDirectoryExist directory exists <- doesFileExist file - let acquire = case exists of + createDirectoryIfMissing True directory + let acquireFile = case exists of True -> return () - False -> createFile file mode >>= closeFd >> writeFile file (show initial ++ "\n") - mode = foldl unionFileModes nullFileMode [ ownerReadMode - , ownerWriteMode - , groupReadMode - , groupWriteMode - ] - release = case exists of + False -> createFile file fileMode >>= closeFd >> writeFile file initial + fileMode = foldl unionFileModes nullFileMode [ ownerReadMode + , ownerWriteMode + , groupReadMode + , groupWriteMode + ] + releaseFile = case exists of True -> return () False -> removeFile file + releaseDir = case dirExists of + True -> return () + False -> removeFile directory + acquire = acquireFile + release = releaseFile >> releaseDir bracket_ acquire release action -handleLevel :: MVar Float -> FilePath -> IO () -handleLevel level file = catch action handler +readLevel :: Chan Level -> MVar Level -> FilePath -> IO () +readLevel levelChan current file = catch action handler where - action = readFile file >>= readIO . stripSpace >>= swapMVar level >>= const (return ()) + action = readFile file >>= readIO . stripSpace >>= writeChan levelChan handler e = if isUserError e - then readMVar level >>= \l -> writeFile file (show l ++ "\n") + then readMVar current >>= writeLevel file else throw e stripSpace = reverse . stripSpace' . reverse . stripSpace' stripSpace' [] = [] stripSpace' l@(x:xs) = if isSpace x then stripSpace' xs else l + +writeLevel :: FilePath -> Level -> IO () +writeLevel file level = writeFile file (show level ++ "\n") -- cgit v1.2.3