JACK.hs

module Main where
-- module Synthesizer.LLVM.Server.JACK where

import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange

import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorSize, vectorSize, )

import qualified Synthesizer.LLVM.Server.Option as Option
import Synthesizer.LLVM.Server.Common

import qualified Synthesizer.MIDI.CausalIO.Process as MIO
import qualified Synthesizer.CausalIO.Process as PIO

import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Storable.Signal as SigStL

import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
import Foreign.Marshal.Array (copyArray, )

import qualified Data.EventList.Relative.TimeTime  as EventListTT
import qualified Data.EventList.Absolute.TimeTime  as EventListAbsTT
import qualified Data.EventList.Absolute.TimeMixed as EventListAbsTM

import qualified Synthesizer.Zip as Zip

import qualified Sound.JACK.Audio as JackAudio
import qualified Sound.JACK.MIDI as JackMIDI
import qualified Sound.JACK.Exception as JackExc
import qualified Sound.JACK as JACK

import Data.IORef (newIORef, readIORef, writeIORef, )

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message as Msg

import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Monad.Trans.Class as MT

import Control.Arrow (Arrow, (<<<), (^<<), arr, )
import Control.Category (id, )
import Control.Applicative (pure, )

import qualified System.Random as Random
{-
import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Chunky  as NonNegChunky
-}
import qualified Numeric.NonNegative.Wrapper as NonNegW

import Prelude hiding (Real, id, )


type StereoVector = StereoInt.T VectorSize Real

type StrictTime = NonNegW.Integer


strictTimeFromNFrames :: JACK.NFrames -> StrictTime
strictTimeFromNFrames (JACK.NFrames n) =
   NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n

writeBlock :: JackAudio.Port JACK.Output -> SV.Vector Real -> IO ()
writeBlock output block = do
   outArr <-
      JackAudio.getBufferPtr output $
         JACK.NFrames $ fromIntegral $ SV.length block
   SVB.withStartPtr (SV.map realToFrac block) $
      copyArray outArr

{-# INLINE playFromEvents #-}
playFromEvents ::
   (JACK.Client ->
    (ports -> Exc.ExceptionalT JackExc.All IO ()) ->
    Exc.ExceptionalT JackExc.All IO ()) ->
   (ports -> block -> IO ()) ->
   Option.T ->
   (SampleRate Real ->
    PIO.T Events block) ->
   IO ()
playFromEvents withOutPorts writeBlocks opt process = do
   let Option.ClientName name = Option.clientName opt
   JACK.handleExceptions $
      JACK.withClientDefault name $ \client ->
      JACK.withPort client "input" $ \input ->
      withOutPorts client $ \output -> do
         sampleRate <- MT.lift $ JACK.getSampleRate client
         case process (SampleRate $ fromIntegral sampleRate) of
            PIO.Cons next create delete ->
               {-
               Is the use of 'bracket' correct?
               I think 'delete' must be called with the final state,
               not with the initial one.
               -}
               Exc.bracketT (MT.lift create) (MT.lift . delete) $ \start -> do
                  stateRef <- MT.lift $ newIORef start
                  let jackProcess nframes = do
                         evs <- JackMIDI.readEventsFromPort input nframes
                         MT.lift $ do
                            let deconsNFrames (JACK.NFrames n) = fromIntegral n
                            (block, state) <-
                               next
                                  (EventListTT.collectCoincident $
                                   EventListTT.mapTime
                                      (NonNegW.fromNumberMsg "JACK.playFromEvents") $
                                   EventListTT.fromAbsoluteEventList $
                                   EventListAbsTT.mapTime
                                      (flip div (fromIntegral vectorSize) .
                                       deconsNFrames) $
                                   EventListAbsTM.snocTime evs nframes)
{-
                                  (EventListTT.collectCoincident $
                                   EventListTT.mapTime strictTimeFromNFrames $
                                   EventListTT.fromAbsoluteEventList $
                                   EventListAbsTM.snocTime evs nframes)
-}
                                  =<< readIORef stateRef
                            writeIORef stateRef state
                            writeBlocks output block
                  JACK.withProcess client jackProcess $
                     JACK.withActivation client $ MT.lift $ do
                        putStrLn $ "started " ++ name ++ "..."
                        JACK.waitForBreak
--                  MT.lift $ readIORef stateRef

playMonoFromEvents ::
   Option.T ->
   (SampleRate Real ->
    PIO.T Events (SV.Vector Vector)) ->
   IO ()
playMonoFromEvents opt proc =
   playFromEvents
      (flip JACK.withPort "mono")
      writeBlock
      opt
      (\sampleRate -> SigStL.unpackStrict ^<< proc sampleRate)

playStereoFromEvents ::
   Option.T ->
   (SampleRate Real ->
    PIO.T Events (Zip.T (SV.Vector Vector) (SV.Vector Vector))) ->
   IO ()
playStereoFromEvents opt proc =
   playFromEvents
      (\client f ->
         JACK.withPort client "left" $ \left ->
         JACK.withPort client "right" $ \right ->
         f (left, right))
      (\(leftPort,rightPort) (Zip.Cons leftBlock rightBlock) ->
         writeBlock leftPort leftBlock >>
         writeBlock rightPort rightBlock)
      opt
      (\sampleRate ->
         Zip.arrowSplit SigStL.unpackStrict SigStL.unpackStrict
         ^<<
         proc sampleRate)


keyboard :: IO ()
keyboard = do
   opt <- Option.get
   proc <- Arrange.keyboard

   playMonoFromEvents opt $ proc (Option.channel opt)


type Events = MIO.Events Msg.T

unconsStereo :: Stereo.T t -> (t, t)
unconsStereo x =
   (Stereo.left x, Stereo.right x)

keyboardFM :: IO ()
keyboardFM = do
   opt <- Option.get
   playStereoFromEvents opt =<<
      Arrange.keyboardFM (arr unconsStereo) (Option.channel opt)


keyboardDetuneFMCore ::
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real ->
       PIO.T
          Events
          (Zip.T (SV.Vector Vector) (SV.Vector Vector)))
keyboardDetuneFMCore =
   Arrange.keyboardDetuneFMCore (arr unconsStereo)

keyboardDetuneFM :: IO ()
keyboardDetuneFM = do
   opt <- Option.get
   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)
   playStereoFromEvents opt $
      proc (Option.channel opt) (VoiceMsg.toProgram 0)

keyboardMultiChannel :: IO ()
keyboardMultiChannel = do
   opt <- Option.get
   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)
   mix <- CausalP.processIO CausalP.mix

   playStereoFromEvents opt $ \ sampleRate ->
      foldl1
         (\x y -> mix () <<< Zip.arrowFanout x y)
         (map
             (\chan ->
                proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)
                     sampleRate)
             [0 .. 3])


voderBand :: IO ()
voderBand = do
   opt <- Option.get
   proc <-
      Arrange.voderBand
         (arr unconsStereo)
         (Option.sampleDirectory opt)

   playStereoFromEvents opt $ \ sampleRate ->
      proc (Option.channel opt) (VoiceMsg.toProgram 5) sampleRate


voderMaskSeparated :: IO ()
voderMaskSeparated = do
   opt <- Option.get
   let postProcessing =
          if True
            then
               let reverb seed =
                      CausalP.reverbEfficient
                         (pure $ Random.mkStdGen seed) 16 (pure (0.92,0.98))
                         (fmap (\(SampleRate rate) -> (round (rate/200), round (rate/40))) id)
               in  CausalPS.pack (Stereo.arrowFromChannels (reverb 42) (reverb 23))
            else id
   proc <-
      Arrange.voderMaskSeparated
         (arr unconsStereo <<< postProcessing)
         (Option.sampleDirectory opt)

   playStereoFromEvents opt $ \ sampleRate ->
      proc
         (Option.channel opt) (Option.extraChannel opt)
         (VoiceMsg.toProgram 4) sampleRate


main :: IO ()
main = keyboardMultiChannel