-- | -- Module : DobutokO.Sound.IntermediateF -- Copyright : (c) OleksandrZhabenko 2020 -- License : MIT -- Stability : Experimental -- Maintainer : olexandr543@yahoo.com -- -- A program and a library to create experimental music -- from a mono audio and a Ukrainian text. {-# OPTIONS_GHC -threaded #-} module DobutokO.Sound.IntermediateF ( -- * Basic functions to work with intermediate files \"result\*wav\" getFileRSizes , getFileRSizesS , getFileRSizesS2 , getFileRTuples , listVDirectory , isHighQ , shouldBeReplaced , indexesFromMrk -- * Functions to edit the melody by editing the intermediate files \"result\*wav\" , playAndMark , playAMrk , pAnR1 , pAnR2 , pAnR_ -- * Additional functions -- ** Get information , infoFromV , internalConv , ixFromRes , ixInterv , thisOne -- ** Process and Edit , playSeqAR , playSeqARV , playSeqARV2 , playCollect1Dec , playCollectDec , replaceWithHQs , isOddAsElem , maxLinV , minLinV , doubleLtoV , filterToBnds -- ** SoX effects application -- *** With \"reverb\" as the first , reverbE , reverbWE , reverb1E , reverbW1E -- *** Generalized , soxE , soxE1 -- *** Playing and recording , recE , rec1E , playE ) where import Control.Concurrent (myThreadId,forkIO,threadDelay,killThread) import qualified Data.List as L (sort) import Control.Exception (onException) import Control.Exception.FinalException (FinalException (NotRecorded,ExecutableNotProperlyInstalled),catchEnd) import Data.List (isPrefixOf,isSuffixOf,(\\),maximum,minimum) import Data.Char (isDigit,isSpace) import qualified Data.Vector as V import System.Directory import SoXBasics (playA,durationA,recA) import EndOfExe (showE) import System.Process (readProcessWithExitCode) import Data.Maybe (fromJust,isJust) import System.Exit (ExitCode (ExitSuccess)) import System.Info (os) import DobutokO.Sound.ParseList (parseStoLInts) -- | Gets sizes of the \"result\*.wav\" files in the current directory. getFileRSizes :: IO (V.Vector Integer) getFileRSizes = do dirN <- listDirectory "." let dirN1 = V.fromList . L.sort . filter (isPrefixOf "result") . filter (isSuffixOf ".wav") $ dirN sizes <- V.mapM getFileSize dirN1 return sizes -- | Similar to 'getFileRSizes', but sizes are 'Int', not 'Integer'. For most cases it is more memory efficient. getFileRSizesS :: IO (V.Vector Int) getFileRSizesS = do dirN0 <- listDirectory "." let dirN2 = V.fromList . L.sort . filter (isPrefixOf "result") . filter (isSuffixOf ".wav") $ dirN0 sizes1 <- V.mapM getFileSize dirN2 return . V.map fromIntegral $ sizes1 -- | Variant of 'getFileRSizes' function. getFileRSizesS2 :: IO (V.Vector Int) getFileRSizesS2 = getFileRSizes >>= \s -> return . V.map fromIntegral $ s -- | Gets 'V.Vector' of tuples of the pairs of \"result\*.wav\" files and their respective sizes. getFileRTuples :: IO (V.Vector (FilePath,Integer)) getFileRTuples = do dirN <- listDirectory "." let dirN0 = L.sort . filter (isPrefixOf "result") . filter (isSuffixOf ".wav") $ dirN sizes0 <- mapM getFileSize dirN0 let tpls = V.fromList . zip dirN0 $ sizes0 return tpls -- | Gets 'V.Vector' of the filenames for \"result\*.wav\" files in the current directory. listVDirectory :: IO (V.Vector FilePath) listVDirectory = do dir0N <- listDirectory "." let diNN = V.fromList . L.sort . filter (\s -> isPrefixOf "result" s && isSuffixOf ".wav" s) $ dir0N return diNN -- | During function evaluation you can listen to the sound files and mark them with \"1\" and \"0\". The first one means that the sound is considered -- of higher quality and is intended to be used as a replacement for the worse sounds markd by \"0\". The function returns a 'V.Vector' of specially formatted -- 'String' that represents only those files that are connected with the replacement procedure. playAndMark :: V.Vector FilePath -> IO (V.Vector String) playAndMark vec | V.null vec = return V.empty | otherwise = V.imapM (\i xs -> do duration <- durationA $ V.unsafeIndex vec i putStrLn "Listen to the next sound, please. Please, do not enter anything while sound plays. " forkIO $ do myThread <- myThreadId playA xs killThread myThread threadDelay (read (show $ truncate (duration * fromIntegral 1000000))::Int) putStr "How do you mark the file that has just been played now -- if of high quality, print \"1\", if of low quality, print \"0\", " putStrLn "if it is just accepted, press \'Enter\'. " mark0 <- getLine putStrLn "-----------------------------------------------------------------------------------------" let mark = take 1 mark0 case mark of "1" -> return $ show i ++ "*" ++ xs "0" -> return $ show i ++ "**" ++ xs _ -> return []) vec >>= V.filterM (\t -> return . not . null $ t) -- | Function 'playAndMark' applied to all the \"result\*.wav\" files in the current directory. playAMrk :: IO (V.Vector String) playAMrk = listVDirectory >>= playAndMark -- | Function-predicate to check whether a file corresponding to its 'String' argument is needed to be replaced while processing. shouldBeReplaced :: String -> Bool shouldBeReplaced (x:y:xs) | x == '*' && y == '*' = True | otherwise = shouldBeReplaced (y:xs) shouldBeReplaced _ = False -- | Function-predicate to check whether a file corresponding to its 'String' argument is considered as one of higher quality and therefore can be used -- to replace the not so suitable ones while processing. isHighQ :: String -> Bool isHighQ xs = (length . filter (== '*') $ xs) == 1 -- | Gets an index of the 'V.Vector' element corresponding to the 'String' generated by 'playAndMark' function. indexesFromMrk :: String -> Int indexesFromMrk xs = read (takeWhile (\t1 -> t1 /= '*') xs)::Int -- | Used to obtain parameters for processment. internalConv :: ([String],[String]) -> (V.Vector Int, V.Vector String) internalConv (xss,yss) = (V.fromList . map indexesFromMrk $ xss,V.fromList . map (dropWhile (== '*')) $ yss) -- | Axiliary function to get a 'String' of consequent digits in the name of the \"result\*.wav\" file. ixFromRes :: String -> String ixFromRes xs = (takeWhile (/= '.') xs) \\ "result" -- | Given an index of the element in the 'listVDirectory' output returns a tuple of the boundaries of the indexes usable for playback. -- Note: index0 is probably from [0..], l1 is necessarily from [0..]. Interesting case is: 0 <= index0 < l1. ixInterv :: Int -> IO (Int, Int) ixInterv index0 | compare index0 0 == LT = do dirV <- listVDirectory let l1 = V.length dirV case compare l1 13 of LT -> return (0,l1 - 1) _ -> return (0,11) | compare index0 7 == LT = do dirV <- listVDirectory let l1 = V.length dirV case compare index0 (l1 - 5) of GT -> return (0, l1 - 1) _ -> return (0, index0 + 4) | otherwise = do dirV <- listVDirectory let l1 = V.length dirV case compare l1 13 of LT -> return (0,l1 - 1) _ -> case compare index0 (l1 - 5) of GT -> return (index0 - 7, l1 - 1) _ -> return (index0 - 7, index0 + 4) -- | Parser to the result of 'listVDirectory' function to get the needed information. infoFromV :: V.Vector String -> [(V.Vector Int, V.Vector String)] infoFromV vec = map (internalConv . unzip . V.toList . V.map (break (== '*'))) [v1, v2] where (v1, v2) = V.partition shouldBeReplaced vec -- | Plays a sequence of sounds in the interval of them obtained by 'ixInterv' function. playSeqAR :: Int -> IO () playSeqAR index0 = do (minBnd,maxBnd) <- ixInterv index0 dirV2 <- listVDirectory mapM_ (\i -> playA $ V.unsafeIndex dirV2 i) [minBnd..maxBnd] -- | Plays a sequence of consequential sounds in the melody in the interval of them obtained by 'ixInterv' function for each element index -- from 'V.Vector' of indexes. playSeqARV :: V.Vector Int -> IO () playSeqARV vec = do dirV2 <- listVDirectory V.mapM_ (\i -> playA $ V.unsafeIndex dirV2 i) vec -- | Plays a sequence of sounds considered of higher quality. playSeqARV2 :: V.Vector String -> IO () playSeqARV2 vec = do let indexesHQs = fst . last . infoFromV $ vec playSeqARV indexesHQs -- | The same as 'playSeqARV2', but additionally collects the resulting 'Bool' values and then returns them. It is used to define, which sounds from those of -- higher quality will replace those ones considered to be replaced. playCollectDec :: V.Vector String -> IO (V.Vector Bool) playCollectDec vec = do dirV3 <- listVDirectory let indexesHQs = fst . last . infoFromV $ vec vecBools <- V.mapM (playCollect1Dec dirV3) indexesHQs return vecBools -- | Actually replaces the file represented by 'FilePath' argument with no (then there is no replacement at all), or with just one, -- or with a sequence of sounds being considered of higher quality to form a new melody. If the lengths of the second and the third -- arguments differs from each other then the function uses as these arguments truncated vectors of the minimal of the two lengths. replaceWithHQs :: FilePath -> V.Vector Bool -> V.Vector FilePath -> IO () replaceWithHQs file0 vecBools stringHQs | V.length vecBools == V.length stringHQs = case V.length stringHQs of 0 -> putStrLn "That's all!" 1 | V.unsafeIndex vecBools 0 -> do copyFile (head . V.toList $ stringHQs) "resultI.wav" renameFile "resultI.wav" file0 | otherwise -> putStrLn "Nothing has changed. " _ -> do let yss = V.toList . V.ifilter (\i _ -> V.unsafeIndex vecBools i == True) $ stringHQs case length yss of 0 -> putStrLn "That's all!" 1 -> copyFile (head yss) file0 _ -> do (_,_,herr) <- readProcessWithExitCode (fromJust (showE "sox")) (yss ++ [file0]) "" putStrLn herr | otherwise = let stringHQ2s = V.take (min (V.length vecBools) (V.length stringHQs)) stringHQs vecBool2s = V.take (min (V.length vecBools) (V.length stringHQs)) vecBools in replaceWithHQs file0 vecBool2s stringHQ2s -- | 'IO' checkbox whether to add the sound played to the sequence of sounds that will replace the needed one. thisOne :: IO Bool thisOne = do putStrLn "Would you like to add this sound played just now to the sequence of sounds that will replace the needed one? " yes <- getLine putStrLn "-----------------------------------------------------------------------" return $ take 1 yes == "1" -- | Plays a sound file considered to be of higher quality and then you define whether to use the played sound to replace that one considered to be replaced. playCollect1Dec :: V.Vector String -> Int -> IO Bool playCollect1Dec dirV2 i | compare i 0 /= LT && compare i (V.length dirV2) /= GT = do playA $ V.unsafeIndex dirV2 i thisOne | otherwise = error "DobutokO.Sound.IntermediateF.playCollect1Dec: wrong Int parameter! " -- | Process the sound corresponding to the first element in the first argument. Returns a 'V.tail' of the first element of the first command line argument. -- Replaces (if specified) the sound with a sequence of (or just one, or made no replacement at all) sounds considered of higher quality. pAnR1 :: V.Vector String -> IO (V.Vector String) pAnR1 vec | V.null vec = putStrLn "You have processed all the marked files! " >> return V.empty | otherwise = do let [(indexes0,strings),(indexesHQ,stringHQs)] = infoFromV vec putStrLn "Please, listen to the melody and remember what sound you would like to replace and the surrounding sounds. " playSeqAR $ V.unsafeIndex indexes0 0 putStrLn "---------------------------------------------------------------" putStrLn "Now, please, listen to a collection of sounds considered of higher quality which you can use to replace the needed one. " vecBools <- playCollectDec vec replaceWithHQs (V.unsafeIndex strings 0) vecBools stringHQs return $ V.map (\(ix,xs) -> show ix ++ "**" ++ xs) . V.zip (V.unsafeDrop 1 indexes0) $ (V.unsafeDrop 1 strings) -- | Process the sounds consequently corresponding to the elements in the first argument. -- Replaces (if specified) the sounds with a sequence of (or just one, or made no replacement at all) sounds considered of higher quality for every sound needed. pAnR2 :: V.Vector String -> IO () pAnR2 vec | V.null vec = putStrLn "You have processed all the marked files! " | otherwise = onException (pAnR1 vec >>= pAnR2) (return ()) -- | Marks the needed files as of needed to be replaced or those ones considered of higher quality that will replace the needed ones. Then actually replaces them -- as specified. Uses internally 'playAMrk' and 'pAnR2' functions. pAnR_ :: IO () pAnR_ = do vec <- playAMrk pAnR2 vec ---------------------------------------------------------------------------------------------------------------- -- | Takes a filename to be applied a SoX \"reverb" effect with parameters of list of 'String' (the second argument). Produces the temporary -- new file with the name ((name-of-the-file) ++ \"reverb.wav\"), which then is removed. Please, remember that for the mono audio -- the after applied function file is stereo with 2 channels. -- -- Besides, you can specify other SoX effects after reverberation in a list of 'String'. The syntaxis is that every separate literal must be -- a new element in the list. If you plan to create again mono audio in the end of processment, then probably use 'reverb1E' funcion instead. -- If you would like to use instead of \"reverb\" its modification \"reverb -w\" effect (refer to SoX documentation), then probably it is more -- convenient to use 'reverbWE' function. Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. reverbE :: FilePath -> [String] -> IO () reverbE file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "reverb.wav","reverb"] ++ arggs) "" case code of ExitSuccess -> do renameFile (file ++ "reverb.wav") file _ -> do removeFile $ file ++ "reverb.wav" putStrLn $ "DobutokO.Sound.IntermediateF.reverbE: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | The same as 'reverbE', but at the end file is being mixed to obtain mono audio. The name of the temporary file is ((name-of-the-file) ++ \"reverb1.wav\"). -- Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. reverb1E :: FilePath -> [String] -> IO () reverb1E file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "reverb1.wav","reverb"] ++ arggs ++ ["channels","1"]) "" case code of ExitSuccess -> do renameFile (file ++ "reverb1.wav") file _ -> do removeFile $ file ++ "reverb1.wav" putStrLn $ "DobutokO.Sound.IntermediateF.reverb1E: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | The same as 'reverbE', but uses \"reverb -w\" effect instead of \"reverb\". The name of the temporary file is -- ((name-of-the-file) ++ \"reverbW.wav\"). Please, for more information, refer to SoX documentation. -- Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. reverbWE :: FilePath -> [String] -> IO () reverbWE file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "reverbW.wav","reverb","-w"] ++ arggs) "" case code of ExitSuccess -> do renameFile (file ++ "reverbW.wav") file _ -> do removeFile $ file ++ "reverbW.wav" putStrLn $ "DobutokO.Sound.IntermediateF.reverbWE: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | The same as 'reverbWE', but at the end file is being mixed to obtain mono audio. The name of the temporary file is ((name-of-the-file) -- ++ \"reverbW1.wav\"). Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. reverbW1E :: FilePath -> [String] -> IO () reverbW1E file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "reverbW1.wav","reverb","-w"] ++ arggs ++ ["channels","1"]) "" case code of ExitSuccess -> do renameFile (file ++ "reverbW1.wav") file _ -> do removeFile $ file ++ "reverbW1.wav" putStrLn $ "DobutokO.Sound.IntermediateF.reverbW1E: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | Takes a filename to be applied a SoX chain of effects (or just one) as list of 'String' (the second argument). Produces the temporary -- new file with the name ((name-of-the-file) ++ \"effects.wav\"), which then is removed. -- -- The syntaxis is that every separate literal for SoX must be a new element in the list. If you plan to create again mono audio in the end of processment, -- then probably use 'soxE1' function instead. Please, for more information, refer to SoX documentation. -- Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. soxE :: FilePath -> [String] -> IO () soxE file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "effects.wav"] ++ arggs) "" case code of ExitSuccess -> do renameFile (file ++ "effects.wav") file _ -> do removeFile $ file ++ "effects.wav" putStrLn $ "DobutokO.Sound.IntermediateF.soxE: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | The same as 'soxE', but at the end file is being mixed to obtain mono audio. -- Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. soxE1 :: FilePath -> [String] -> IO () soxE1 file arggs = do (code,_,_) <- readProcessWithExitCode (fromJust (showE "sox")) ([file,file ++ "effects.wav"] ++ arggs ++ ["channels","1"]) "" case code of ExitSuccess -> do renameFile (file ++ "effects.wav") file _ -> do removeFile $ file ++ "effects.wav" putStrLn $ "DobutokO.Sound.IntermediateF.soxE1: file \"" ++ file ++ "\" has not been successful. The file has not been changed at all. " -- | Function takes a 'FilePath' for the new recorded file (if it already exists then it is overwritten) and a list of 'String'. The last one is -- sent to SoX rec or something equivalent as its arguments after the filename. If you plan just afterwards to produce mono audio, it's simpler to use -- 'rec1E' function instead. Please, check by yourself whether you have enough permissions to read and write to the 'FilePath'-specified -- file and to the containing it directory. The function is not intended to be used in otherwise cases. -- Function is adopted and changed 'SoXBasics.recA' function. recE :: FilePath -> [String] -> IO () recE file arggs | isJust (showE "sox") && take 5 os == "mingw" = do (code, _, _) <- readProcessWithExitCode (fromJust (showE "sox")) (["-t","waveaudio","-d", file] ++ arggs)"" if code /= ExitSuccess then do e0 <- doesFileExist file if e0 then do removeFile file catchEnd (NotRecorded file) else catchEnd (NotRecorded file) else do e1 <- doesFileExist file if e1 then return () else catchEnd (NotRecorded file) | isJust (showE "rec") = do (code, _, _) <- readProcessWithExitCode (fromJust (showE "rec")) ([file] ++ arggs) "" if code /= ExitSuccess then do e0 <- doesFileExist file if e0 then do removeFile file catchEnd (NotRecorded file) else catchEnd (NotRecorded file) else do e1 <- doesFileExist file if e1 then return () else catchEnd (NotRecorded file) | otherwise = catchEnd ExecutableNotProperlyInstalled -- | Function takes a 'FilePath' for the new recorded file (if it already exists then it is overwritten) and a list of 'String'. The last one is -- sent to SoX rec or something equivalent as its arguments after the filename. Please, check by yourself whether you have enough permissions -- to read and write to the 'FilePath'-specified file and to the containing it directory. The function is not intended to be used in otherwise cases. -- Function is adopted and changed 'SoXBasics.recA' function. rec1E :: FilePath -> [String] -> IO () rec1E file arggs | isJust (showE "sox") && take 5 os == "mingw" = do (code, _, _) <- readProcessWithExitCode (fromJust (showE "sox")) (["-t","waveaudio","-d", file] ++ arggs ++ ["channels","1"])"" if code /= ExitSuccess then do e0 <- doesFileExist file if e0 then do removeFile file catchEnd (NotRecorded file) else catchEnd (NotRecorded file) else do e1 <- doesFileExist file if e1 then return () else catchEnd (NotRecorded file) | isJust (showE "rec") = do (code, _, _) <- readProcessWithExitCode (fromJust (showE "rec")) ([file] ++ arggs ++ ["channels","1"]) "" if code /= ExitSuccess then do e0 <- doesFileExist file if e0 then do removeFile file catchEnd (NotRecorded file) else catchEnd (NotRecorded file) else do e1 <- doesFileExist file if e1 then return () else catchEnd (NotRecorded file) | otherwise = catchEnd ExecutableNotProperlyInstalled -- | Plays a 'FilePath' file with a SoX further effects specified by the list of 'String'. It can be e. g. used to (safely) test the result of applying -- some SoX effects and only then to use 'soxE' or some similar functions to actually apply them. -- Please, check by yourself whether you have enough permissions to read the 'FilePath'-specified -- file and the containing it directory. The function is not intended to be used in otherwise cases. -- Function is adopted and changed 'SoXBasics.playA' function. playE :: FilePath -> [String] -> IO () playE file arggs | take 5 os == "mingw" = if isJust (showE "sox") then readProcessWithExitCode (fromJust (showE "sox")) ([file, "-t", "waveaudio", "-d"] ++ arggs) "" >> return () else catchEnd ExecutableNotProperlyInstalled | otherwise = if isJust (showE "play") then readProcessWithExitCode (fromJust (showE "play")) ([file] ++ arggs) "" >> return () else catchEnd ExecutableNotProperlyInstalled ------------------------------------------------------------------------------------------- -- | A predicate to decide whether an element @a@ belongs to the odd number of the lists of @a@ in the 'V.Vector'. isOddAsElem :: Eq a => a -> V.Vector [a] -> Bool isOddAsElem x v | V.null v = False | otherwise = (V.length . V.findIndices (elem x) $ v) `rem` 2 == 1 -- | All @[a]@ must be finite. To obtain @Just a0@ as a result, at least one of the @[a]@ must be not empty and 'V.Vector' must have finite length. -- If 'V.Vector' is 'V.empty' or all @[a]@ are null (the vector has finite length), then the result is 'Nothing'. Otherwise, it will run infinitely -- just until it runs over the available memory. maxLinV :: Ord a => V.Vector [a] -> Maybe a maxLinV v | V.all null v || V.null v = Nothing | otherwise = Just (V.maximum . V.map maximum . V.filter (not . null) $ v) -- | All @[a]@ must be finite. To obtain @Just a0@ as a result, at least one of the @[a]@ must be not empty and 'V.Vector' must have finite length. -- If 'V.Vector' is 'V.empty' or all @[a]@ are null (the vector has finite length), then the result is 'Nothing'. Otherwise, it will run infinitely -- just until it runs over the available memory. minLinV :: Ord a => V.Vector [a] -> Maybe a minLinV v | V.all null v || V.null v = Nothing | otherwise = Just (V.minimum . V.map minimum . V.filter (not . null) $ v) -- | Applied to list of @[a]@ where a is an instance for 'Ord' class gives a sorted in the ascending order 'V.Vector' of @a@, each of them being unique. doubleLtoV :: Ord a => [[a]] -> V.Vector a doubleLtoV xss = V.fromList . shortenL . L.sort . concat $ xss where shortenL z1@(z:_) | length (takeWhile (== z) z1) `rem` 2 == 1 = z:shortenL (dropWhile (== z) z1) | otherwise = shortenL (dropWhile (== z) z1) shortenL _ = [] -- | Filters 'Int' elements in a list so that they are limited with the first two 'Int' arguments of the function as a lower and a higher bounds. filterToBnds :: Int -> Int -> [Int] -> [Int] filterToBnds lbnd hbnd xs = filter (\x -> compare x lbnd /= LT && compare x hbnd /= GT) xs