{-# OPTIONS_GHC -threaded #-}
module DobutokO.Sound.IntermediateF (
getFileRSizes
, getFileRSizesS
, getFileRSizesS2
, getFileRTuples
, listVDirectory
, isHighQ
, shouldBeReplaced
, indexesFromMrk
, playAndMark
, playAMrk
, pAnR1
, pAnR2
, pAnR_
, infoFromV
, internalConv
, ixFromRes
, ixInterv
, thisOne
, playSeqAR
, playSeqARV
, playSeqARV2
, playCollect1Dec
, playCollectDec
, replaceWithHQs
, isOddAsElem
, maxLinV
, minLinV
, doubleLtoV
, filterToBnds
, reverbE
, reverbWE
, reverb1E
, reverbW1E
, soxE
, soxE1
, 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)
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
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
getFileRSizesS2 :: IO (V.Vector Int)
getFileRSizesS2 = getFileRSizes >>= \s -> return . V.map fromIntegral $ s
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
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
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)
playAMrk :: IO (V.Vector String)
playAMrk = listVDirectory >>= playAndMark
shouldBeReplaced :: String -> Bool
shouldBeReplaced (x:y:xs)
| x == '*' && y == '*' = True
| otherwise = shouldBeReplaced (y:xs)
shouldBeReplaced _ = False
isHighQ :: String -> Bool
isHighQ xs = (length . filter (== '*') $ xs) == 1
indexesFromMrk :: String -> Int
indexesFromMrk xs = read (takeWhile (\t1 -> t1 /= '*') xs)::Int
internalConv :: ([String],[String]) -> (V.Vector Int, V.Vector String)
internalConv (xss,yss) = (V.fromList . map indexesFromMrk $ xss,V.fromList . map (dropWhile (== '*')) $ yss)
ixFromRes :: String -> String
ixFromRes xs = (takeWhile (/= '.') xs) \\ "result"
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)
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
playSeqAR :: Int -> IO ()
playSeqAR index0 = do
(minBnd,maxBnd) <- ixInterv index0
dirV2 <- listVDirectory
mapM_ (\i -> playA $ V.unsafeIndex dirV2 i) [minBnd..maxBnd]
playSeqARV :: V.Vector Int -> IO ()
playSeqARV vec = do
dirV2 <- listVDirectory
V.mapM_ (\i -> playA $ V.unsafeIndex dirV2 i) vec
playSeqARV2 :: V.Vector String -> IO ()
playSeqARV2 vec = do
let indexesHQs = fst . last . infoFromV $ vec
playSeqARV indexesHQs
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
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
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"
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! "
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)
pAnR2 :: V.Vector String -> IO ()
pAnR2 vec
| V.null vec = putStrLn "You have processed all the marked files! "
| otherwise = onException (pAnR1 vec >>= pAnR2) (return ())
pAnR_ :: IO ()
pAnR_ = do
vec <- playAMrk
pAnR2 vec
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. "
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. "
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. "
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. "
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. "
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. "
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
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
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
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
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)
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)
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 _ = []
filterToBnds :: Int -> Int -> [Int] -> [Int]
filterToBnds lbnd hbnd xs = filter (\x -> compare x lbnd /= LT && compare x hbnd /= GT) xs