module Synthesizer.Storable.ALSA.Server.Test where

import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr
import Synthesizer.Storable.ALSA.Server.Common
          (Real, withMIDIEvents, play,
           sampleRate, chunkSize, channel, )

import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Event as Event

import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC
import qualified Synthesizer.Generic.ALSA.MIDI as Gen
import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt
import Synthesizer.Storable.ALSA.MIDI (
   Instrument, chunkSizesFromLazyTime, )

import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv
import Synthesizer.EventList.ALSA.MIDI (
   LazyTime, StrictTime, Note(..), NoteBoundary(..),
   matchNoteEvents, getSlice, getControllerEvents, )

import qualified Synthesizer.Basic.Wave          as Wave

import qualified Synthesizer.Causal.Process as Causal
import Control.Arrow ((<<<), )

import qualified Synthesizer.Storable.Cut         as CutSt
import qualified Synthesizer.Storable.Oscillator  as OsciSt
import qualified Synthesizer.Storable.Signal      as SigSt
-- import qualified Data.StorableVector.Lazy.Builder as Bld
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy         as SVL
import qualified Data.StorableVector              as SV

import qualified Synthesizer.State.Signal      as SigS

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

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.BodyTime  as EventListBT
import Data.EventList.Relative.MixedBody ((/.), (./), )

import qualified Control.Monad.Trans.State.Strict as MS
import Control.Monad.Trans.State (evalState, gets, )
import Control.Category ((.), )

import Data.Traversable (traverse, )

-- import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky

import qualified Algebra.RealRing as RealRing
import qualified Algebra.Additive  as Additive

import Data.Maybe.HT (toMaybe, )

import NumericPrelude.Numeric (zero, round, (^?), )
import Prelude hiding (Real, round, break, id, (.), )


import Data.Word (Word8, )


frequency1 :: IO ()
frequency1 =
   withMIDIEvents play $
      const
        (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))

frequency2 :: IO ()
frequency2 =
   withMIDIEvents (const $ const print) $
      evalState (getControllerEvents channel VoiceMsg.mainVolume)

frequency3 :: IO ()
frequency3 =
   withMIDIEvents (const $ const print) $
      evalState (getSlice Just)


keyboard1 :: IO ()
keyboard1 =
   withMIDIEvents play $
      const (Instr.ping 0 440)

keyboard2 :: SigSt.T Real
keyboard2 =
   let music :: Real -> EventList.T StrictTime (SigSt.T Real)
       music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)
   in  CutSt.arrange chunkSize $
       EventList.mapTime fromIntegral $ music 42

keyboard3 :: SigSt.T Real
keyboard3 =
   let time :: Real -> Int
       time t = round (t * sampleRate)
       music :: Real -> EventList.T StrictTime (SigSt.T Real)
       music x =
          fromIntegral (time 0.2) /.
          SigSt.take (time 0.4) (Instr.ping 0 x) ./
          music (x*1.01)
   in  CutSt.arrange chunkSize $
       EventList.mapTime fromIntegral $ music 110

makeLazyTime :: Real -> LazyTime
makeLazyTime t =
   NonNegChunky.fromNumber $
   NonNegW.fromNumberMsg "keyboard time" $
   round (t * sampleRate)

makeStrictTime :: Real -> StrictTime
makeStrictTime t =
   NonNegW.fromNumberMsg "keyboard time" $
   round (t * sampleRate)

normalVelocity :: VoiceMsg.Velocity
normalVelocity =
   VoiceMsg.toVelocity VoiceMsg.normalVelocity

pitch :: Int -> VoiceMsg.Pitch
pitch = VoiceMsg.toPitch

defaultProgram :: VoiceMsg.Program
defaultProgram = VoiceMsg.toProgram 0

embedDefaultProgram ::
   EventList.T StrictTime [NoteBoundary Bool] ->
   EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]
embedDefaultProgram =
   fmap (fmap (\(NoteBoundary p v b) ->
      NoteBoundary p v (toMaybe b defaultProgram)))

keyboard4 :: SigSt.T Real
keyboard4 =
   let {-
       idInstr :: Real -> Real -> SigSt.T Real
       idInstr _vel freq = SigSt.repeat chunkSize freq
       -}
--       inf = time 0.4 + inf
       music :: Int -> EventList.T StrictTime Note
       music p =
          makeStrictTime 0.2 /.
--          (pitch p, normalVelocity, inf) ./
          Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./
          music (p+1)
   in  CutSt.arrange chunkSize $
       EventList.mapTime fromIntegral $
       fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $
       music 0


notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool)
notes0 p =
   makeStrictTime 0.2 /.
   (let (oct,pc) = divMod p 12
    in  (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))
      ./
   notes0 (p+1)

notes1 :: EventList.T StrictTime (NoteBoundary Bool)
notes1 =
   makeStrictTime 0.2 /.
   (NoteBoundary (pitch 50) normalVelocity True) ./
   makeStrictTime 0.2 /.
   (NoteBoundary (pitch 52) normalVelocity True) ./
   makeStrictTime 0.2 /.
   (NoteBoundary (pitch 54) normalVelocity True) ./
   makeStrictTime 0.2 /.
--   (NoteBoundary (pitch 50) normalVelocity False) ./
   undefined

notes2 :: EventList.T StrictTime [NoteBoundary Bool]
notes2 =
   makeStrictTime 0.2 /.
   [] ./
   makeStrictTime 0.2 /.
   [] ./
   makeStrictTime 0.2 /.
   [NoteBoundary (pitch 50) normalVelocity True] ./
   makeStrictTime 0.2 /.
   [NoteBoundary (pitch 52) normalVelocity True] ./
   makeStrictTime 0.2 /.
   [NoteBoundary (pitch 54) normalVelocity True] ./
   makeStrictTime 0.2 /.
   [NoteBoundary (pitch 50) normalVelocity False] ./
   undefined

notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]
notes3 =
   embedDefaultProgram $
   notes2

keyboard5 :: SigSt.T Real
keyboard5 =
   CutSt.arrange chunkSize $
   EventList.mapTime fromIntegral $
   Gen.flatten $
   fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $
   matchNoteEvents $
   notes3

keyboard6 :: EventList.T StrictTime [Note]
keyboard6 =
   matchNoteEvents $
   embedDefaultProgram $
   fmap (:[]) $
   notes1

keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)]
keyboard7 =
   fmap (map (\ ~(Note _ p v _d) -> (p,v))) $
   keyboard6

arrangeSpaceLeak0 :: IO ()
arrangeSpaceLeak0 =
   SVL.writeFile "test.f32" $
   evalState (Gen.sequence (CutSt.arrange chunkSize) channel
      (error "no sound" :: Instrument Real Real)) $
   let evs = EventList.cons 10 [] evs
   in  evs

arrangeSpaceLeak1 :: IO ()
arrangeSpaceLeak1 =
   SVL.writeFile "test.f32" $
   evalState
      (Gen.sequenceModulated (CutSt.arrange chunkSize)
         (SigSt.iterate chunkSize (1+) 0) channel
         (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $
   let evs = EventList.cons 10 [] evs
   in  evs

makeNote :: Event.NoteEv -> Word8 -> Event.T
makeNote typ pit =
   Event.Cons
      { Event.highPriority = False
      , Event.tag = 0
      , Event.queue = Queue.direct
      , Event.timestamp =
           Event.RealTime $ RealTime.fromInteger 0
      , Event.source = Addr.Cons {
           Addr.client = Client.subscribers,
           Addr.port = Port.unknown
        }
      , Event.dest = Addr.Cons {
           Addr.client = Client.subscribers,
           Addr.port = Port.unknown
        }
      , Event.body =
           Event.NoteEv typ
              (Event.simpleNote 0 pit 64)
      }

{-
a space leak can only be observed for more than one note,
maybe our 'break' improvement fixed the case for one played note
-}
arrangeSpaceLeak3 :: IO ()
arrangeSpaceLeak3 =
   SVL.writeFile "test.f32" $
   evalState
      (Gen.sequenceModulated (CutSt.arrange chunkSize)
         (SigSt.iterate chunkSize (1e-7 +) 1) channel
         Instr.stringStereoFM) $
--         (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $
   let evs t = EventList.cons t [] (evs (20-t))
   in  -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $
       -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $
       evs 10

arrangeSpaceLeak4 :: IO ()
arrangeSpaceLeak4 =
   SVL.writeFile "test.f32" $
   evalState
      (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1
          AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $
   let evs t = EventList.cons t [] (evs (20-t))
   in  evs 10

chordSpaceLeak1 :: IO ()
chordSpaceLeak1 =
   SVL.writeFile "test.f32" $
   evalState
      (Gen.sequence (CutSt.arrange chunkSize)
          channel Instr.pingDur) $
   let evs t = EventList.cons t [] (evs (20-t))
   in  EventList.cons 10 [makeNote Event.NoteOn 60] $
       EventList.cons 10 [makeNote Event.NoteOn 64] $
       evs 10


sequencePitchBend :: IO ()
sequencePitchBend =
   SVL.writeFile "test.f32" $
      evalState
         (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))
          in  Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel
                 (error "no sound" ::
                     PC.T Real -> Instrument Real Real)) $
      let evs = EventList.cons 10 [] evs
      in  evs

sequencePitchBend1 :: IO ()
sequencePitchBend1 =
   SVL.writeFile "test.f32" $
      evalState
         (let fm y = EventListBT.cons y 10 (fm (2-y))
              instr :: PC.T Real -> Instrument Real Real
              instr = error "no sound"
          in  Gen.sequenceCore
                 (CutSt.arrange chunkSize) channel Gen.errorNoProgram
                 (Gen.Modulator (fm 1) Gen.advanceModulationChunk
                     (\note -> gets $ \c ->
                         Gen.renderInstrumentIgnoreProgram (instr c) note))) $
      let evs = EventList.cons 10 [] evs
      in  evs

sequencePitchBend2 :: IO ()
sequencePitchBend2 =
   SVL.writeFile "test.f32" $
      let fm y = EventListBT.cons y 10 (fm (2-y))
          -- fm = EventListBT.cons 1 10 fm
          instr :: PC.T Real -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
          md =
             Gen.Modulator
                (fm 1)
                Gen.advanceModulationChunkPC
                -- Gen.advanceModulationChunk
                (\note -> gets $ \c ->
                    Gen.renderInstrumentIgnoreProgram (instr c) note)
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          Gen.applyModulator md $
          evs

sequencePitchBend3 :: IO ()
sequencePitchBend3 =
   SVL.writeFile "test.f32" $
      let fm y = EventListBT.cons y 10 (fm (2-y))
          -- fm = EventListBT.cons 1 10 fm
          instr :: PC.T Real -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
          modEvent note =
             gets $ \c ->
                Gen.renderInstrumentIgnoreProgram (instr c) note
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          flip evalState (fm 1) .
          EventList.traverse
             Gen.advanceModulationChunk
             (traverse modEvent) $
          evs

sequencePitchBend4 :: IO ()
sequencePitchBend4 =
   SVL.writeFile "test.f32" $
      let fm y = y : fm (2-y)
          -- fm = repeat 1
          instr :: [Real] -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
          modEvent note =
             gets $ \c ->
                Gen.renderInstrumentIgnoreProgram (instr c) note
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          flip evalState (fm 1) .
          EventList.traverse
             Gen.advanceModulationChunk
             (traverse modEvent) $
          evs

sequencePitchBend4a :: IO ()
sequencePitchBend4a =
   SVL.writeFile "test.f32" $
      let fm y = y : fm (2-y)
          -- fm = repeat 1
          instr :: [Real] -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
          modEvent note =
             MS.gets $ \c ->
                Gen.renderInstrumentIgnoreProgram (instr c) note
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          flip MS.evalState (fm 1) .
          EventList.traverse
             Gen.advanceModulationChunkStrict
             (traverse modEvent) $
          evs

sequencePitchBend4b :: IO ()
sequencePitchBend4b =
   SVL.writeFile "test.f32" $
      let fm y = y : fm (2-y)
          -- fm = repeat 1
          instr :: [Real] -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
      in  CutSt.arrange chunkSize .
          Gen.flatten $
          EventList.foldrPair
             (\t bs0 go s0 ->
                let s1 = tail s0
                    bs1 =
                       map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0
                in  EventList.cons
                       (if null s1 then t else t) bs1 $
                    go s1)
             (const EventList.empty) evs (fm 1)

sequencePitchBend4c :: IO ()
sequencePitchBend4c =
   SVL.writeFile "test.f32" $
      let fm y = y : fm (2-y)
          -- fm = repeat 1
          instr :: [Real] -> Instrument Real Real
          instr = error "no sound"
      in  CutSt.arrange chunkSize .
          Gen.flatten .
          EventList.fromPairList $
          foldr
             (\(t,bs0) go s0 ->
                let s1 = tail s0
                    bs1 =
                       map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0
                in  (if null s1 then t else t, bs1) :
                    go s1)
             (const [])
             (repeat (10,[]))
             (fm 1)

sequencePitchBend4d :: IO ()
sequencePitchBend4d =
   SVL.writeFile "test.f32" $
      let fm y = y : fm (2-y)
          -- fm = repeat 1
      in  CutSt.arrange chunkSize .
          EventList.fromPairList $
          foldr
             (\(t,b) go s0 ->
                let s1 = tail s0
                in  (if null s1 then t else t,
                     if null s1 then b else b) :
                    go s1)
             (const [])
             (repeat (10, SigSt.empty :: SigSt.T Real))
             (fm 1 :: [Real])

sequencePitchBend4e :: IO ()
sequencePitchBend4e =
   writeFile "test.txt" $
   foldr
      (\c go s0 ->
         let s1 = tail s0
         in  (if null s1 then c else c) :
             go s1)
      (const [])
      (repeat 'a')
      (iterate not False)
      -- (repeat True)

sequencePitchBend5 :: IO ()
sequencePitchBend5 =
   SVL.writeFile "test.f32" $
      let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0
          instr :: SigSt.T Real -> Instrument Real Real
          instr = error "no sound"
          evs = EventList.cons 10 [] evs
          modEvent note =
             gets $ \c ->
                Gen.renderInstrumentIgnoreProgram (instr c) note
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          flip evalState (fm 1e-6) .
          EventList.traverse
             Gen.advanceModulationChunk
             (traverse modEvent) $
          evs

dummySound :: Instrument Real Real
dummySound =
   \vel freq dur ->
      SigStV.take (chunkSizesFromLazyTime dur) $
      SigSt.repeat chunkSize (vel + 1e-3*freq)

sequenceStaccato :: IO ()
sequenceStaccato =
   SVL.writeFile "test.f32" $
      let evs t =
             EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $
             EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $
             evs (20-t)
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          EventList.mapBody
             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .
          MIDIEv.matchNoteEvents .
          MIDIEv.embedPrograms defaultProgram $
          evs 10

sequenceStaccato3 :: IO ()
sequenceStaccato3 =
   SVL.writeFile "test.f32" $
      let evs t =
             EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $
             EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $
             evs (20-t)
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          EventList.mapBody
             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .
          MIDIEv.matchNoteEvents $
          evs 10

sequenceStaccato2 :: IO ()
sequenceStaccato2 =
   SVL.writeFile "test.f32" $
      let evs t =
             EventList.cons t [makeNote Event.NoteOn  60] $
             EventList.cons t [makeNote Event.NoteOff 60] $
             evs (20-t)
      in  CutSt.arrange chunkSize .
          EventList.mapTime fromIntegral .
          Gen.flatten .
          EventList.mapBody
             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .
          MIDIEv.matchNoteEvents .
          MIDIEv.embedPrograms defaultProgram .
          evalState (MIDIEv.getNoteEvents channel) $
          evs 10

sequenceStaccato1 :: IO ()
sequenceStaccato1 =
   SVL.writeFile "test.f32" $
      evalState
         (do Gen.sequence (CutSt.arrange chunkSize) channel dummySound) $
      let evs t =
             EventList.cons t [makeNote Event.NoteOn  60] $
             EventList.cons t [makeNote Event.NoteOff 60] $
             evs (20-t)
      in  evs 10


speed :: IO ()
speed =
   let _sig =
          Causal.apply
             (Instr.softStringCausalProcess 440 <<<
              Instr.softStringReleaseEnvelopeCausalProcess 0)
             (SigS.repeat True)
       sig =
          Causal.apply
             (Instr.softStringCausalProcess 440)
             (SigS.repeat 1)
   in  SV.writeFile "speed.f32" $
       SigS.runViewL sig
       (\next s -> fst $ SV.unfoldrN 1000000 next s)

speedChunky :: IO ()
speedChunky =
   let sig =
          Causal.apply
             (Instr.softStringCausalProcess 440 <<<
              Instr.softStringReleaseEnvelopeCausalProcess 0)
             (SigS.repeat True)
   in  SVL.writeFile "speed.f32" $
       SigSt.take 1000000 $
       SigS.toStorableSignal (SVL.chunkSize 100) sig
{-
       SigS.runViewL sig
       (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))
-}

speedArrange :: IO ()
speedArrange =
   let sig =
          Causal.apply
             (Instr.softStringCausalProcess 440 <<<
              Instr.softStringReleaseEnvelopeCausalProcess 0)
             (SigS.repeat True)
       sigSt =
          SigS.toStorableSignal (SVL.chunkSize 100) sig
   in  SVL.writeFile "speed.f32" $
       SigSt.take 1000000 $
       CutSt.arrangeEquidist (SVL.chunkSize 100) $
       EventList.fromPairList [(10000,sigSt)]