module Main where

import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.State.Cut as Cut
import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Frame.Stereo as Stereo

import qualified Sound.Sox.Write         as SoxWrite
import qualified Sound.Sox.Read          as SoxRead
import qualified Sound.Sox.Option.Format as SoxOption
import qualified Sound.Sox.Frame         as SoxFrame
import Control.Exception (bracket, )

import qualified Data.StorableVector.Lazy as SVL

import Text.Printf (printf, )

import qualified Control.Monad.Trans.State as MS
import Control.Monad ((<=<), )
import Control.Arrow ((<<<), (^<<), )

import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Tuple.HT (swap, )
import Data.Foldable (forM_, )
import Control.Functor.HT (void, )

import Foreign.Storable (Storable, )

import NumericPrelude.Numeric
import NumericPrelude.Base

import Prelude ()


-- * parameters

newtype Time = Time Float
   deriving (Eq, Show)

newtype Freq = Freq Float
   deriving (Eq, Show)

data Flags =
   Flags {
      sampleRate :: Int,
      smooth, humFreq :: Freq,
      pauseVolume :: Float,
      minPause, prePause :: Time
   }

defltFlags :: Flags
defltFlags =
   Flags {
      sampleRate = 44100,
      smooth = Freq 1,
      humFreq = Freq 100,
      pauseVolume = 0.02,
      minPause = Time 2,
      {-
      Sometimes a piece starts with breath which is almost undetectable.
      Thus we start a little bit earlier than necessary.
      -}
      prePause = Time 1.5
      -- prePause = Time 0.05
   }

freq :: (Flags -> Freq) -> (Flags -> Float)
freq acc flags =
   (case acc flags of Freq f -> f) / fromIntegral (sampleRate flags)

time :: (Flags -> Time) -> (Flags -> Int)
time acc flags =
   round ((case acc flags of Time t -> t) * fromIntegral (sampleRate flags))



-- * computation

dehum :: Flags -> Causal.T (Stereo.T Float) (Stereo.T Float)
dehum flags =
   Filt1.highpass_
   ^<<
   Filt1.causal
   <<<
   Causal.feedConstFst (Filt1.parameter (freq humFreq flags))

trackEnvelope :: Flags -> Causal.T (Stereo.T Float) Float
trackEnvelope flags =
   Filt1.lowpassCausal
   <<<
   Causal.feedConstFst (Filt1.parameter (freq smooth flags))
   <<<
   Causal.map (\x -> sqrt (Stereo.left x^2 + Stereo.right x^2))

threshold :: Flags -> Causal.T Float Bool
threshold flags = Causal.map (< pauseVolume flags)

findStarts :: Flags -> Causal.T Bool Bool
findStarts flags =
   flip Causal.fromState 0 $ \b ->
      if b
        then MS.modify succ >> evalReturn False
        else do n <- MS.get; MS.put 0; return (n >= time minPause flags)

measurePauses :: Causal.T Bool (Maybe Int)
measurePauses =
   flip Causal.fromState 0 $ \b ->
      if b
        then do n <- MS.get; MS.put 1; return (Just n)
        else MS.modify succ >> evalReturn Nothing

evalReturn :: a -> MS.State Int a
evalReturn x =
   MS.gets (\n -> seq n x)

pieceDurations :: Flags -> SVL.Vector (Stereo.T Float) -> [Int]
pieceDurations flags =
--   catMaybes . Sig.toList .
   Sig.foldR (maybe id (:)) [] .
   Causal.apply
      (measurePauses <<< findStarts flags <<<
       threshold flags <<< trackEnvelope flags <<< dehum flags) .
   Sig.fromStorableSignal

chop, chopLazy ::
   Flags -> SVL.Vector (Stereo.T Float) -> [SVL.Vector (Stereo.T Float)]
chop flags sig0 =
   let prefetch _ [] = []
       prefetch n (s:ss) =
          if s <= n
            then prefetch (n-s) ss
            else (s-n) : ss
   in  snd $ List.mapAccumL (\sig n -> swap $ SVL.splitAt n sig) sig0 $
       prefetch (time prePause flags) $ pieceDurations flags sig0

chopLazy flags sig =
   flip Cut.chopStorable sig .
   Sig.drop (time prePause flags) .
   Causal.apply
      (findStarts flags <<< threshold flags <<<
       trackEnvelope flags <<< dehum flags) .
   Sig.fromStorableSignal $ sig


-- * driver

withSound ::
   (SoxFrame.C a, Storable a) =>
   Int -> FilePath -> (SVL.Vector a -> IO b) -> IO b
withSound numChannels path act =
   bracket
      (SoxRead.open (SoxOption.numberOfChannels numChannels) path)
      SoxRead.close $
   act . snd <=<
   SoxRead.withHandle2 (SVL.hGetContentsAsync SVL.defaultChunkSize)


shorten :: (Storable a) => SVL.Vector a -> SVL.Vector a
shorten = SVL.take (25*10^6)

runDehum :: FilePath -> FilePath -> Flags -> IO ()
runDehum input output flags =
   withSound 2 input $ \sig ->
   void $
   SoxWrite.simple SVL.hPut (SoxOption.bitsPerSample 16)
      output (sampleRate flags)
      (Causal.apply (dehum flags) sig)

runEnvelope :: FilePath -> FilePath -> Flags -> IO ()
runEnvelope input output flags =
   withSound 2 input $ \sig ->
   void $
   SoxWrite.simple SVL.hPut (SoxOption.bitsPerSample 16)
      output (sampleRate flags)
      (Causal.apply (trackEnvelope flags <<< dehum flags) sig)

runSizes :: FilePath -> Flags -> IO ()
runSizes input flags =
   withSound 2 input $ \sig ->
   mapM_ print $ pieceDurations flags sig
{-
   mapM_ (putStr . show) $
      computePieceDurationsTest sig
-}

runLabels :: FilePath -> Flags -> IO ()
runLabels input flags =
   withSound 2 input $ \sig ->
   mapM_ (\(n, (from,to)) -> printf "%s\t%s\t%d\n" from to n) $
   zip [(0::Int) ..] $
   ListHT.mapAdjacent (,) $
   map (\t ->
      case divMod (div (fromIntegral t * 10^6) (fromIntegral (sampleRate flags))) (10^6) of
         (seconds,micros) ->
            printf "%d,%06d" seconds (micros::Integer) :: String) $
   scanl (+) 0 $ (pieceDurations flags) sig

{- |
> runChop "in.wav" "%03d.wav" flags
-}
runChop :: FilePath -> FilePath -> Flags -> IO ()
runChop input output flags =
   withSound 2 input $ \sig ->
   forM_ (zip [(0::Int)..] $ chopLazy flags sig) $ \(n,piece) ->
      void $
      SoxWrite.simple SVL.hPut (SoxOption.bitsPerSample 16)
         (printf output n) (sampleRate flags) piece

main :: IO ()
main = runLabels "komplett.wav" defltFlags