From 4658cc95745dbdffd7bc1be2e61fa463b28b4a16 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Jun 2015 19:40:40 +0200 Subject: Added adjmix --- adjmix/Adjmix.hs | 71 ++++++++++++++ src/Trivmix.hs | 257 --------------------------------------------------- src/Trivmix/Types.hs | 90 ++++++++++++++++++ trivmix.cabal | 23 ++++- trivmix.nix | 12 +-- trivmix/Trivmix.hs | 215 ++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 402 insertions(+), 266 deletions(-) create mode 100644 adjmix/Adjmix.hs delete mode 100644 src/Trivmix.hs create mode 100644 src/Trivmix/Types.hs create mode 100644 trivmix/Trivmix.hs diff --git a/adjmix/Adjmix.hs b/adjmix/Adjmix.hs new file mode 100644 index 0000000..49b820f --- /dev/null +++ b/adjmix/Adjmix.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +import Options.Applicative + +import System.FilePath + +import Data.Char + +import Trivmix.Types + +data Options = Options + { baseDirectory :: FilePath + , targetDirectory :: FilePath + , levelFile :: FilePath + , adjustment :: Adjustment Level + } +optionParser :: Parser Options +optionParser = Options + <$> strOption ( long "base" + <> metavar "DIRECTORY" + <> value "/dev/shm/mix" + ) + <*> strOption ( long "target" + <> short 't' + <> metavar "DIRECTORY" + <> help "Directory relative to ‘--base’ containing the level file" + ) + <*> strOption ( long "level" + <> metavar "FILENAME" + <> value "level" + <> help "Filename of the level file" + ) + <*> ( ( Set <$> option auto ( long "set" + <> short 'o' + <> metavar "LEVEL" + ) + ) + <|> ( Add <$> option auto ( long "add" + <> short 'a' + <> metavar "LEVEL" + ) + ) + <|> ( Sub <$> option auto ( long "sub" + <> short 's' + <> metavar "LEVEL" + ) + ) + ) + +main :: IO () +main = execParser opts >>= adjmix + where + opts = info (helper <*> optionParser) + ( fullDesc + <> progDesc "Adjust the level file of a trivmix" + <> header "Adjmix — A trivial interface to a trivial mixer" + ) + +adjmix :: Options -> IO () +adjmix Options{..} = do + oldLevel <- readFile levelFile >>= readIO . stripSpace + let + newLevel = oldLevel `doAdjustment` adjustment + writeFile levelFile (show newLevel ++ "\n") + where + levelFile = baseDirectory targetDirectory levelFile + stripSpace = reverse . stripSpace' . reverse . stripSpace' + stripSpace' [] = [] + stripSpace' l@(x:xs) = if isSpace x + then stripSpace' xs + else l diff --git a/src/Trivmix.hs b/src/Trivmix.hs deleted file mode 100644 index 37ecec6..0000000 --- a/src/Trivmix.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -import Foreign.C.Types (CFloat(..)) -import qualified Sound.JACK as Jack -import qualified Sound.JACK.Audio as Audio - -import Options.Applicative - -import Data.Maybe - -import System.Directory -import System.FilePath -import System.Posix.Files -import System.Posix.IO -import System.Posix.Types -import System.Environment -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 - -import Control.Exception -import System.IO.Error -import System.IO - -import System.FileLock -import System.INotify - -import Data.Char -import Data.Function - -import Control.Monad - -import Data.Fixed - -import Data.CaseInsensitive ( CI ) -import qualified Data.CaseInsensitive as CI - -data Options = Options - { input :: String - , output :: String - , client :: String - , run :: Maybe String - , levelFiles :: [FilePath] - } - -data Level = Lin Float | DB Float - -withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b -withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p') - -withType :: (p a -> f a) -> f a -withType f = f undefined - -withResolution :: (HasResolution a) => (Integer -> f a) -> f a -withResolution f = withType (f . resolution) - -instance Show Level where - show (Lin x) = show x - show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB" - where - x' = 20 * (logBase 10 x) - -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 $ 10 ** (0.05 * f), rest) - | otherwise = (Lin f, str) - where - prec = take lU str - rest = drop lU str - unit = "dB" - lU = length unit - -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 - -optionParser :: Parser Options -optionParser = Options <$> - (fromMaybe "in" <$> optional (strOption ( long "input" - <> metavar "STRING" - ) - ) - ) - <*> (fromMaybe "out" <$> optional (strOption ( long "output" - <> metavar "STRING" - ) - ) - ) - <*> strOption ( long "client" - <> metavar "STRING" - ) - <*> optional ( strOption ( long "run" - <> metavar "FILE" - ) - ) - <*> some (strArgument ( metavar "FILE..." - <> help "Files that contain levels to assume and synchronize" - ) - ) - -watchedAttrs :: [EventVariety] -watchedAttrs = [ Modify - , Move - , MoveIn - , MoveOut - , MoveSelf - , Create - , Delete - , DeleteSelf - ] - -initialLevel :: Level -initialLevel = Lin 0 - -defFileMode :: FileMode -defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode - , ownerWriteMode - , groupReadMode - , groupWriteMode - , otherReadMode - ] - -defDirectoryMode :: FileMode -defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes - , groupModes - , otherReadMode - , otherExecuteMode - ] -main :: IO () -main = execParser opts >>= trivmix - where - opts = info (helper <*> optionParser) - ( fullDesc - <> progDesc "Setup a JACK mixing input/output pair controlled by files" - <> header "Trivmix - A trivial mixer" - ) - -trivmix :: Options -> IO () -trivmix Options{..} = do - level <- newMVar initialLevel - let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles - withFiles $ withINotify $ \inotify -> do - handleFiles inotify level levelFiles - Jack.handleExceptions $ - Jack.withClientDefault client $ \client' -> - Jack.withPort client' input $ \input' -> - Jack.withPort client' output $ \output' -> do - Trans.lift $ do - case run of - Nothing -> return () - Just run' -> do - (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True } - return () - Audio.withProcessMono client' input' (mix level) output' $ - Jack.withActivation client' $ Trans.lift Jack.waitForBreak - -mix :: MVar Level -> CFloat -> IO CFloat -mix level input = do - level' <- readMVar level - return $ (CFloat $ toFloat level') * input - where - toFloat (Lin x) = x - toFloat (DB x) = x - -handleFiles :: INotify -> MVar Level -> [FilePath] -> IO () -handleFiles inotify level files = do - initLevel <- readMVar level - levelChanges <- (newChan :: IO (Chan Level)) - stderrLock <- newEmptyMVar - let - handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock) - mapM_ handleFile files - forkIO $ forever $ do -- Broadcast level changes and update all files - levelState <- readChan levelChanges - swapMVar level levelState - mapM_ (\f -> writeLevel f stderrLock levelState) files - return () - return () - -onStateFile :: FilePath -> String -> IO a -> IO a -onStateFile file initial action = do - let directory = takeDirectory file - directories = iterate takeDirectory directory - createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories - exists <- doesFileExist file - let acquireFile = case exists of - True -> return () - False -> do - hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)" - createFile file defFileMode >>= closeFd >> writeFile file initial - releaseFile = case exists of - True -> return () - False -> do - hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)" - removeFile file - acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do - hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)" - createDirectory directory - setFileMode directory defDirectoryMode - releaseDir = (flip mapM) createDirs $ \directory -> do - hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)" - removeDirectory directory - acquire = acquireDir >> acquireFile - release = releaseFile >> releaseDir - bracket_ acquire release action - -takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a] -takeWhileM _ [] = return [] -takeWhileM pred (x:xs) = do - take <- pred x - case take of - True -> do - rest <- takeWhileM pred xs - return $ x:rest - False -> do - return [] - -readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO () -readLevel levelChan current file stderrLock = catch action handler - where - action = do - level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace - oldLevel <- readMVar current - when (oldLevel /= level) $ do - writeChan levelChan level - withMVarLock stderrLock $ - hPutStrLn stderr $ "Detected new level: " ++ (show level) - handler e = if isUserError e - then do - withMVarLock stderrLock $ - hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting." - readMVar current >>= writeLevel file stderrLock - else throw e - stripSpace = reverse . stripSpace' . reverse . stripSpace' - stripSpace' [] = [] - stripSpace' l@(x:xs) = if isSpace x - then stripSpace' xs - else l - -writeLevel :: FilePath -> MVar () -> Level -> IO () -writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do - withMVarLock stderrLock $ - hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" - writeFile file (show level ++ "\n") - -withMVarLock :: MVar () -> IO a -> IO a -withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock) diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs new file mode 100644 index 0000000..66accdf --- /dev/null +++ b/src/Trivmix/Types.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Trivmix.Types + ( Level + , toFloat + , Adjustment(..) + , doAdjustment + , module Data.Default + ) where + +import Data.Fixed +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + +import Data.Default + +import Data.Function (on) + +data Level = Lin Float | DB Float + +instance Num Level where + (+) = asFloat (+) + (-) = asFloat (-) + (*) = asFloat (*) + abs = Lin . abs . toFloat + signum = Lin . signum . toFloat + fromInteger = Lin . fromInteger + +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 + +toFloat :: Level -> Float +toFloat (Lin x) = x +toFloat (DB x) = x + +withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b +withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p') + +withType :: (p a -> f a) -> f a +withType f = f undefined + +withResolution :: (HasResolution a) => (Integer -> f a) -> f a +withResolution f = withType (f . resolution) + +instance Show Level where + show (Lin x) = show x + show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB" + where + x' = 20 * (logBase 10 x) + +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 $ 10 ** (0.05 * f), rest) + | otherwise = (Lin f, str) + where + prec = take lU str + rest = drop lU str + unit = "dB" + lU = length unit + +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 + +instance Default Level where + def = Lin 0 + +data Adjustment a = Set a + | Add a + | Sub a + deriving (Show, Eq) + +class Adjustable a where + add :: a -> a -> a + sub :: a -> a -> a + +instance Num a => Adjustable a where + add = (+) + sub = (-) + +doAdjustment :: Adjustable a => a -> Adjustment a -> a +doAdjustment _ (Set y) = y +doAdjustment x (Add y) = add x y +doAdjustment x (Sub y) = sub x y diff --git a/trivmix.cabal b/trivmix.cabal index 40aa9a8..0e02a7d 100644 --- a/trivmix.cabal +++ b/trivmix.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: trivmix -version: 2.4.6 +version: 2.5.0 -- synopsis: -- description: license: PublicDomain @@ -15,6 +15,14 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.10 +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Trivmix.Types + build-depends: base >=4.7 && <4.8 + , data-default >=0.5 && <1 + , case-insensitive >=1.2 && <2 + executable trivmix main-is: Trivmix.hs -- other-modules: @@ -29,12 +37,21 @@ executable trivmix , transformers >=0.3 && <1 , explicit-exception >=0.1 && <1 , process >=1.2 && <2 - , case-insensitive >=1.2 && <2 , filelock >=0.1 && <1 - hs-source-dirs: src + , trivmix + hs-source-dirs: trivmix default-language: Haskell2010 ghc-options: -threaded +executable adjmix + main-is: Adjmix.hs + build-depends: base >=4.7 && <4.8 + , optparse-applicative >=0.11 && <1 + , filepath >=1.3 && <2 + , trivmix + hs-source-dirs: adjmix + default-language: Haskell2010 + -- Local Variables: -- firestarter: "nix-shell -p haskellPackages.cabal2nix --command 'cabal2nix ./.' | tee trivmix.nix" -- End: diff --git a/trivmix.nix b/trivmix.nix index fae88fc..6edcff0 100644 --- a/trivmix.nix +++ b/trivmix.nix @@ -1,18 +1,18 @@ # This file was auto-generated by cabal2nix. Please do NOT edit manually! -{ cabal, caseInsensitive, explicitException, filelock, filepath -, hinotify, jack, optparseApplicative, transformers +{ cabal, caseInsensitive, dataDefault, explicitException, filelock +, filepath, hinotify, jack, optparseApplicative, transformers }: cabal.mkDerivation (self: { pname = "trivmix"; - version = "2.4.6"; + version = "2.5.0"; src = ./.; - isLibrary = false; + isLibrary = true; isExecutable = true; buildDepends = [ - caseInsensitive explicitException filelock filepath hinotify jack - optparseApplicative transformers + caseInsensitive dataDefault explicitException filelock filepath + hinotify jack optparseApplicative transformers ]; meta = { license = self.stdenv.lib.licenses.publicDomain; diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs new file mode 100644 index 0000000..9f0cf22 --- /dev/null +++ b/trivmix/Trivmix.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE RecordWildCards #-} + +import Foreign.C.Types (CFloat(..)) +import qualified Sound.JACK as Jack +import qualified Sound.JACK.Audio as Audio + +import Options.Applicative + +import Data.Maybe + +import System.Directory +import System.FilePath +import System.Posix.Files +import System.Posix.IO +import System.Posix.Types +import System.Environment +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 + +import Control.Exception +import System.IO.Error +import System.IO + +import System.FileLock +import System.INotify + +import Data.Char +import Data.Function + +import Control.Monad + +import Trivmix.Types + +data Options = Options + { input :: String + , output :: String + , client :: String + , run :: Maybe String + , levelFiles :: [FilePath] + } + +optionParser :: Parser Options +optionParser = Options <$> + (fromMaybe "in" <$> optional (strOption ( long "input" + <> metavar "STRING" + ) + ) + ) + <*> (fromMaybe "out" <$> optional (strOption ( long "output" + <> metavar "STRING" + ) + ) + ) + <*> strOption ( long "client" + <> metavar "STRING" + ) + <*> optional ( strOption ( long "run" + <> metavar "FILE" + ) + ) + <*> some (strArgument ( metavar "FILE..." + <> help "Files that contain levels to assume and synchronize" + ) + ) + +watchedAttrs :: [EventVariety] +watchedAttrs = [ Modify + , Move + , MoveIn + , MoveOut + , MoveSelf + , Create + , Delete + , DeleteSelf + ] + +initialLevel :: Level +initialLevel = def + +defFileMode :: FileMode +defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode + , ownerWriteMode + , groupReadMode + , groupWriteMode + , otherReadMode + ] + +defDirectoryMode :: FileMode +defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes + , groupModes + , otherReadMode + , otherExecuteMode + ] +main :: IO () +main = execParser opts >>= trivmix + where + opts = info (helper <*> optionParser) + ( fullDesc + <> progDesc "Setup a JACK mixing input/output pair controlled by files" + <> header "Trivmix - A trivial mixer" + ) + +trivmix :: Options -> IO () +trivmix Options{..} = do + level <- newMVar initialLevel + let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles + withFiles $ withINotify $ \inotify -> do + handleFiles inotify level levelFiles + Jack.handleExceptions $ + Jack.withClientDefault client $ \client' -> + Jack.withPort client' input $ \input' -> + Jack.withPort client' output $ \output' -> do + Trans.lift $ do + case run of + Nothing -> return () + Just run' -> do + (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True } + return () + Audio.withProcessMono client' input' (mix level) output' $ + Jack.withActivation client' $ Trans.lift Jack.waitForBreak + +mix :: MVar Level -> CFloat -> IO CFloat +mix level input = do + level' <- readMVar level + return $ (CFloat $ toFloat level') * input + +handleFiles :: INotify -> MVar Level -> [FilePath] -> IO () +handleFiles inotify level files = do + initLevel <- readMVar level + levelChanges <- (newChan :: IO (Chan Level)) + stderrLock <- newEmptyMVar + let + handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock) + mapM_ handleFile files + forkIO $ forever $ do -- Broadcast level changes and update all files + levelState <- readChan levelChanges + swapMVar level levelState + mapM_ (\f -> writeLevel f stderrLock levelState) files + return () + return () + +onStateFile :: FilePath -> String -> IO a -> IO a +onStateFile file initial action = do + let directory = takeDirectory file + directories = iterate takeDirectory directory + createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories + exists <- doesFileExist file + let acquireFile = case exists of + True -> return () + False -> do + hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)" + createFile file defFileMode >>= closeFd >> writeFile file initial + releaseFile = case exists of + True -> return () + False -> do + hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)" + removeFile file + acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do + hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)" + createDirectory directory + setFileMode directory defDirectoryMode + releaseDir = (flip mapM) createDirs $ \directory -> do + hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)" + removeDirectory directory + acquire = acquireDir >> acquireFile + release = releaseFile >> releaseDir + bracket_ acquire release action + +takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a] +takeWhileM _ [] = return [] +takeWhileM pred (x:xs) = do + take <- pred x + case take of + True -> do + rest <- takeWhileM pred xs + return $ x:rest + False -> do + return [] + +readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO () +readLevel levelChan current file stderrLock = catch action handler + where + action = do + level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace + oldLevel <- readMVar current + when (oldLevel /= level) $ do + writeChan levelChan level + withMVarLock stderrLock $ + hPutStrLn stderr $ "Detected new level: " ++ (show level) + handler e = if isUserError e + then do + withMVarLock stderrLock $ + hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting." + readMVar current >>= writeLevel file stderrLock + else throw e + stripSpace = reverse . stripSpace' . reverse . stripSpace' + stripSpace' [] = [] + stripSpace' l@(x:xs) = if isSpace x + then stripSpace' xs + else l + +writeLevel :: FilePath -> MVar () -> Level -> IO () +writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do + withMVarLock stderrLock $ + hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" + writeFile file (show level ++ "\n") + +withMVarLock :: MVar () -> IO a -> IO a +withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock) -- cgit v1.2.3