autocut/app/Main.hs

module Main (main) where

import Lib
import Parser
import Driver
import Types

import qualified System.Console.GetOpt as Opt
import qualified Algebra.RealRing as Real
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.List.HT as ListHT
import qualified Synthesizer.Basic.Binary as Bin
import qualified Synthesizer.Causal.Process as Causal
import Shell.Utility.Exit (exitFailureMsg)
import System.Environment (getArgs, getProgName, )
import Control.Monad (when, )
import Text.Printf (printf, )
import Data.Foldable (forM_, )
import Control.Arrow (arr, (<<<), (^<<), )
import System.Console.GetOpt
          (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), )
import qualified Sound.SoxLib as SoxLib
import Data.Int (Int32, )

--runDehum :: Flags -> FilePath -> FilePath -> IO ()
--runDehum flags input output =
--   withSound flags input $ \fmtIn params sig ->
--   SoxLib.withWrite
--      (writerInfoFromFormat fmtIn params)
--      output $ \fmtOut ->
--         SoxLib.writeStorableVectorLazy fmtOut $
--         SVL.interleaveFirstPattern $
--         map
--            (Causal.apply
--               (arr (Bin.fromCanonicalWith Real.roundSimple)
--                <<<
--                dehum params
--                <<<
--                arr Bin.toCanonical)) $
--         SVL.deinterleave (numChannels params) sig

--runEnvelope :: Flags -> FilePath -> FilePath -> IO ()
--runEnvelope flags input output =
--   withSound flags input $ \fmtIn params sig ->
--   SoxLib.withWrite
--      (monoInfoFromFormat fmtIn params)
--      output $ \fmtOut ->
--         SoxLib.writeStorableVectorLazy fmtOut $
--         Causal.apply
--            (arr (Bin.fromCanonicalWith Real.roundSimple)) $
--         trackEnvelope params $
--         map
--            (Causal.apply
--               (arr (^2)
--                <<<
--                dehum params
--                <<<
--                arr Bin.toCanonical)) $
--         SVL.deinterleave (numChannels params) sig

--runSizes :: Flags -> FilePath -> IO ()
--runSizes flags input =
--   withSound flags input $ \_fmt params sig ->
--   mapM_ print $ pieceDurations params sig

runLabels :: Flags -> FilePath -> IO ()
runLabels flags input =
   withSound flags input $ \_fmt params sig ->
   mapM_ (\(n, (from,to)) -> printf "%s\t%s\t%d\n" from to n) $
   zip [(0::Int) ..] $
   ListHT.mapAdjacent (,) $
   map (\t ->
      case divMod (Real.roundSimple (fromIntegral t * 10^6 / sampleRate params)) (10^6) of
         -- FIXME: the comma is certainly only correct in German locale
         (seconds,micros) ->
            printf "%d,%06d" seconds (micros::Integer) :: String) $
   scanl (+) 0 $
   prefetch (preStart params) $
   pieceDurations params sig

getChops :: Flags -> FilePath -> IO [SVL.Vector Int32]
getChops flags input = withSound flags input $ \_ params sig -> do
    let ps = chopLazy params sig
        a = show ps
    putStrLn $ [last a]
    return $! ps
{- |
> runChop flags "in.wav" "%03d.wav"
-}
runChop :: Flags -> FilePath -> FilePath -> IO ()
runChop flags input output =
   withSound flags input $ \fmtIn params sig ->
   forM_ (zip [(0::Int)..] $ chopLazy params sig) $ \(n,piece) ->
      print piece
      --SoxLib.withWrite
      --   (writerInfoFromFormat fmtIn params)
      --   (printf output n) $ \fmtOut ->
      --      SoxLib.writeStorableVectorLazy fmtOut piece

main :: IO ()
main = SoxLib.formatWith $ do
   argv <- getArgs
   let (opts, files, errors) =
          getOpt Opt.RequireOrder description argv
   when (not $ null errors) $
      exitFailureMsg (init (concat errors))

   flags <- foldl (>>=) (return defltFlags) opts

   --if flagComputeEnvelope flags
   --  then
   --    case files of
   --       [input,output] -> runEnvelope flags input output
   --       [] -> exitFailureMsg "need input and output file envelope computation"
   --       _ -> exitFailureMsg "more than two file names given"
   --  else
   case files of
      --[input,output] -> runChop flags input output
      [input] -> getChops flags input >>= print --runLabels flags input
      [] -> exitFailureMsg "no input or output given"
      _ -> exitFailureMsg "more than two file names given"