-- |
-- Module      :  DobutokO.Sound.Faded
-- Copyright   :  (c) OleksandrZhabenko 2020
-- License     :  MIT
-- Stability   :  Experimental
-- Maintainer  :  olexandr543@yahoo.com
--
-- Helps to create experimental music. 
-- Uses SoX fade (in a special 2D way) and frequency modulation.

{-# OPTIONS_GHC -threaded #-}
{-# LANGUAGE CPP #-}

module DobutokO.Sound.Faded (
  -- * Create special faded effects
  overChangeVolG
  , overChangeVolGC
  , overChangeVolGF
  , overChangeVol
  , overChangeVolC
  , overChangeVolF
  -- * Mixing function
  , mixGTest
  -- * Generate several files
  , basicF
  , basicFC
  , basicF2
  , basicF2C
  -- * Auxiliary functions
  , endingWF
  , charFadeType
  , argString
  , freqChange
) where

#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__>=710
/* code that applies only to GHC 7.10.* and higher versions */
import GHC.Base (mconcat)
#endif
#endif
import System.Exit (ExitCode (ExitSuccess))
import Data.List (isPrefixOf,isSuffixOf)
import Data.Maybe (fromJust)
import System.Process
import EndOfExe (showE)
import MMSyn7l (fadeEndsTMB,fadeEndsTMN)
import Numeric (showFFloat)
import qualified Data.Vector as V
import System.Directory
import DobutokO.Sound.Functional.Basics
import DobutokO.Sound.IntermediateF (soxBasicParams)
import Data.Vector.DoubleZip (evalSndFV)

#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__==708
/* code that applies only to GHC 7.8.* */
mconcat = concat
#endif
#endif

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale with possibily changing frequency (they are specified by 
-- the first and the second 'Double' arguments). Uses SoX inside especially \"fade\" and \"synth\" effects. For the equal frequencies generates specifically 
-- faded output. 
overChangeVolG :: String -> String -> Int -> Double -> Double -> Double -> Double -> ((Double,Double), (Double,Double)) -> IO ()
overChangeVolG ys cs j freq1 freq2 x0 xdelta ((t0,v0), (t1,v1)) 
 | x0 /= 0 && compare (abs x0) 1.0 /= GT && compare freq1 16 == GT && compare freq1 20000 == LT = 
  case compare (v1 * v0) 0 of 
    GT -> do
     (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) (soxBasicParams ys ["","-n","test1.wav","synth", 
       showFFloat Nothing (if t1 == t0 then abs x0 else abs (t1 - t0)) "", "sine", showFFloat (Just 4) freq1 (freqChange (drop 1 cs) freq2 freq1), "fade", 
        charFadeType (if null cs then 'l' else head cs)] ++ 
         if compare ((v1 - v0) * (t1 - t0)) 0 /= LT then [showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) ""] 
           else ["0", "-0.0", showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "vol", 
             showFFloat (Just 4) (signum v1 * abs (v1 - v0)) ""]) ""
     if code1 /= ExitSuccess then error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr1
     else do
      (code2,_,herr2) <- readProcessWithExitCode (fromJust (showE "sox")) (soxBasicParams ys ["","-n","test0.wav","synth", 
        showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "sine", 
          showFFloat (Just 4) freq1 (freqChange (drop 1 cs) freq2 freq1), "vol", showFFloat (Just 4) (min v0 v1) ""]) ""
      if code2 == ExitSuccess 
        then do
          (code3,_,herr3) <- readProcessWithExitCode (fromJust (showE "sox")) ["-m","test0" ++ endingWF ys,"test1" ++ endingWF ys, "testG" ++ 
            prependZeroes 6 (show j) ++ endingWF ys, "vol", "2"] ""
          if code3 == ExitSuccess 
            then removeFile ("test0" ++ endingWF ys) >> removeFile ("test1" ++ endingWF ys)
            else error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr3
        else print herr2 >> error "DobutokO.Sound.Times.overChangeVol: Operation not successful. "
    LT -> do  
     overChangeVolG ys cs j freq1 freq2 x0 xdelta ((t0,v0), ((v0 * t1 - v1 * t0) / (v0 - v1),0)) >> renameFile ("testG" ++ prependZeroes 6 (show j) ++ 
       endingWF ys) ("temp0" ++ endingWF ys)
     overChangeVolG ys cs j freq1 freq2 x0 xdelta (((v0 * t1 - v1 * t0) / (v0 - v1),0), (t1,v1)) >> renameFile ("testG" ++ prependZeroes 6 (show j) ++ 
       endingWF ys) ("temp1" ++ endingWF ys)
     (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) ["temp0" ++ endingWF ys,"temp1" ++ endingWF ys, "testG" ++ 
       prependZeroes 6 (show j) ++ endingWF ys] ""
     if code1 == ExitSuccess then removeFile ("temp0" ++ endingWF ys) >> removeFile ("temp1" ++ endingWF ys)
     else error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr1 
    _  -> 
     case v1 of 
      0 -> 
       if v0 == 0 
        then do
          (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) (soxBasicParams ys ["","-n","testG" ++ prependZeroes 6 (show j) ++ 
            ".wav","delay", showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "trim", showFFloat Nothing 
              (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) ""]) ""
          if code1 /= ExitSuccess then error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr1
          else return ()
        else do 
          (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) (soxBasicParams ys ["","-n","testG" ++ prependZeroes 6 (show j) ++ 
            ".wav","synth", showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "sine", 
              showFFloat (Just 4) freq1 (freqChange (drop 1 cs) freq2 freq1), "fade", charFadeType (if null cs then 'l' else head cs)] ++ 
               if compare t0 t1 == GT then [showFFloat Nothing 
                (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) ""] else ["0", "-0.0", showFFloat Nothing 
                  (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "vol", showFFloat (Just 4) v0 ""]) ""
          if code1 /= ExitSuccess then error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr1
          else return ()
      _ -> do
       (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) (soxBasicParams ys ["","-n","testG" ++ prependZeroes 6 (show j) ++ ".wav",
         "synth", showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", "sine", 
          showFFloat (Just 4) freq1 (freqChange (drop 1 cs) freq2 freq1), "fade", charFadeType (if null cs then 'l' else head cs)] ++ 
           if compare t1 t0 == GT 
            then [showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 
             else abs (t1 - t0)) ""] else ["0", "-0.0", showFFloat Nothing (if compare (abs (t1 - t0)) xdelta /= GT then abs x0 else abs (t1 - t0)) "", 
               "vol", showFFloat (Just 4) v1 ""]) ""
       if code1 /= ExitSuccess then error $ "DobutokO.Sound.Times.overChangeVol: " ++ herr1
       else return ()
 | otherwise = error "DobutokO.Sound.Times.overChangeVol: sound for these conditions is not defined. "

freqChange :: String -> Double -> Double -> String
freqChange xs freq freq1 
 | compare freq 16 /= LT && compare freq 20000 /= GT = if freq /= freq1 then
   case xs of 
    "l" -> ':':showFFloat (Just 4) freq ""
    "s" -> '+':showFFloat (Just 4) freq ""
    "e" -> '/':showFFloat (Just 4) freq ""
    _ -> '-':showFFloat (Just 4) freq "" 
     else ""
 | otherwise = error "DobutokO.Sound.Faded.freqChange: undefined for this value of the frequency (the first Double argument). "

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale. Uses SoX inside especially \"fade\" 
-- and \"synth\" effects. A frequency does not change and is specified (in Hz) by the first 'Double' argument.
overChangeVol :: String -> Char -> Int -> Double -> Double -> Double -> ((Double,Double), (Double,Double)) -> IO () 
overChangeVol ys c j freq1 = overChangeVolG ys [c] j freq1 freq1

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale. Uses SoX inside especially \"fade\" 
-- and \"synth\" effects. A frequency does not change and is specified (in Hz) by the first 'Double' argument. Is a curried variant of the 
-- 'overChangeVol' in its two last arguments.
overChangeVolC :: String -> Char -> Int -> Double -> Double -> Double -> (Double,Double) -> (Double,Double) -> IO ()
overChangeVolC ys c j freq x0 xdelta w1 = overChangeVol ys c j freq x0 xdelta . (,) w1

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale with possibily changing frequency (they are specified by 
-- the first and the second 'Double' arguments). Uses SoX inside especially \"fade\" and \"synth\" effects. For the equal frequencies generates specifically 
-- faded output. Is a curried variant of the 'overChangeVolG' in its two last arguments.
overChangeVolGC :: String -> String -> Int -> Double -> Double -> Double -> Double -> (Double,Double) -> (Double,Double) -> IO ()
overChangeVolGC ys cs j freq1 freq2 x0 xdelta w1 = overChangeVolG ys cs j freq1 freq2 x0 xdelta . (,) w1

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale. Uses SoX inside especially \"fade\" 
-- and \"synth\" effects. Is a somewhat flipped variant of the 'overChangeVol' with changed order of the arguments (is provided here for convenience).
overChangeVolF :: String -> Char -> Int -> Double -> Double -> (Double,Double) -> (Double,Double) ->  Double -> IO ()
overChangeVolF ys c j x0 xdelta w1 w2 freq  = overChangeVol ys c j freq x0 xdelta (w1,w2)

-- | Generates sound the volume of which comes through the given 2D points in the time-volume scale with possibily changing frequency (they are specified by 
-- the first and the second 'Double' arguments). Uses SoX inside especially \"fade\" and \"synth\" effects. For the equal frequencies generates specifically 
-- faded output. Is a somewhat flipped variant of the 'overChangeVolG' with changed order of the arguments (is provided here for convenience).
overChangeVolGF :: String -> String -> Int -> Double -> Double -> (Double,Double) -> (Double,Double) ->  Double -> Double -> IO ()
overChangeVolGF ys cs j x0 xdelta w1 w2 freq1 freq2  = overChangeVolG ys cs j freq1 freq2 x0 xdelta (w1,w2)

-- | A simplified variant of the 'soxBasicParameters' function with defining only file extension.
endingWF :: String -> String
endingWF ys 
 | not (null ys) = if last ys == 'f' then ".flac" else ".wav"
 | otherwise = ".wav"

-- | Converts a character into a corresponding string using as a default one \"l\" (a logarithmic one). An output can specify then the fade type for SoX.
charFadeType :: Char -> String
charFadeType c = 
  case c of
   'h' -> "h"
   'p' -> "p"
   't' -> "t"
   _  -> "l"

-- | Using SoX mixes all the \"testG*\" (of the WAV or FLAC extension specified by the 'String' argument -- see 'endingWF') in the current directory. 
-- If there are \"resultG.*" (wav or flac respectively) file in the directory, it is overwritten. Also the "testG*" files are deleted afterwards if the 
-- mixing is successful.
mixGTest :: String -> IO ()
mixGTest ys = do
  dir <- listDirectory "."
  (code1,_,herr1) <- readProcessWithExitCode (fromJust (showE "sox")) (mconcat [["-m"], filter (\xs -> "testG" `isPrefixOf` xs && 
    endingWF ys `isSuffixOf` xs) dir, ["resultG" ++ endingWF ys]]) ""
  if code1 /= ExitSuccess then error $ "DobutokO.Sound.Times.mixGTest: " ++ herr1
  else mapM_ removeFile . filter (\xs -> "testG" `isPrefixOf` xs && endingWF ys `isSuffixOf` xs) $ dir
  
-- | Generates a sequence of sounds using 'overChangeVol' so that their time-volume characteristic is going through the 2D points obtained 
-- with the last two arguments.
-- Uses 'fadeEndsTMB', the arguments for which are specified by the second symbol in the second 'String' and by the third 'Double' argument.
basicF :: String -> String -> Double -> Double -> Double -> Double -> (Double -> Double) -> V.Vector Double -> IO ()
basicF ys x2s freq x0 xdelta per f v = do
  let (xs1,xs2) = splitAt 1 x2s
      c1 = if null xs1 then 'l' else head xs1
      c2 = if null xs2 then 'l' else head xs2
  v1 <- evalSndFV f v
  V.imapM_ (\i x -> do
    overChangeVol ys c1 i freq x0 xdelta x
    fadeEndsTMB c2 per $ "testG" ++ prependZeroes 6 (show i) ++ endingWF ys) v1

-- | Splits its argument (like 'splitAt') into two 'String' with the length of (if possible) 4 and 2 characters. The rest of the argument is not used.
argString :: String -> (String,String)
argString xs = (take 4 xs,take 2 . drop 4 $ xs)

-- | Generates a sequence of sounds using 'overChangeVol' so that their time-volume characteristic is going through the 2D points obtained 
-- with the last two arguments.
-- The 'String' should consist of 6 alphanumeric characters. The first four as for the 'soxBasicParams' and the last two -- letters from the \"hlpqt\". 
-- Otherwise, the default values are used (\"221w\" for the first and \"ll\" for the second one).
basicFC :: String -> Double -> Double -> Double -> Double -> (Double -> Double) -> V.Vector Double -> IO ()
basicFC xs freq x0 xdelta per f v = let (ys,x2s) = argString xs in basicF ys x2s freq x0 xdelta per f v

-- | Generates a sequence of sounds using 'overChangeVol' so that their time-volume characteristic is going through the 2D points obtained 
-- with the last two arguments.
-- Uses 'fadeEndsTMN', the arguments for which are specified by the second symbol in the second 'String' and by the third and fourth 'Double' arguments.
basicF2 :: String -> String -> Double -> Double -> Double -> Double -> Double -> (Double -> Double) -> V.Vector Double -> IO ()
basicF2 ys x2s freq x0 xdelta per1 per2 f v = do
  let (xs1,xs2) = splitAt 1 x2s
      c1 = if null xs1 then 'l' else head xs1
      c2 = if null xs2 then 'l' else head xs2
  v1 <- evalSndFV f v
  V.imapM_ (\i x -> do
    overChangeVol ys c1 i freq x0 xdelta x
    fadeEndsTMN c2 per1 per2 $ "testG" ++ prependZeroes 6 (show i) ++ endingWF ys) v1

-- | Generates a sequence of sounds using 'overChangeVol' so that their time-volume characteristic is going through the 2D points obtained 
-- with the last two arguments.
-- The 'String' should consist of 6 alphanumeric characters. The first four as for the 'soxBasicParams' and the last two -- letters from the \"hlpqt\". 
-- Otherwise, the default values are used (\"221w\" for the first and \"ll\" for the second one).
basicF2C :: String -> Double -> Double -> Double -> Double -> Double -> (Double -> Double) -> V.Vector Double -> IO ()
basicF2C xs freq x0 xdelta per1 per2 f v = let (ys,x2s) = argString xs in basicF2 ys x2s freq x0 xdelta per1 per2 f v