{-# LANGUAGE Rank2Types #-}
module Reactive.Banana.ALSA.Example where

import qualified Reactive.Banana.ALSA.Training as Training
import qualified Reactive.Banana.ALSA.Pattern as Pattern
import qualified Reactive.Banana.ALSA.KeySet as KeySet
import qualified Reactive.Banana.ALSA.Sequencer as Seq
import qualified Reactive.Banana.ALSA.Time as Time
import qualified Reactive.Banana.ALSA.Common as Common
import Reactive.Banana.ALSA.Common
          (NoteBoundaryExt(NoteBoundaryExt), NoteBoundary(NoteBoundary),
           program, channel, pitch, controller, )

import qualified Reactive.Banana.ALSA.Utility as RBU

import qualified Reactive.Banana.Frameworks as RBF
import qualified Reactive.Banana.Combinators as RB
import Reactive.Banana.Combinators ((<@>), )

import qualified Sound.MIDI.Message.Class.Check as Check

import qualified System.Random as Random

import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, )
import Control.Applicative (pure, (<*>), )
import Data.Tuple.HT (mapFst, )
import Data.Maybe (mapMaybe, )

import Prelude hiding (reverse, )


run, runLLVM, runTimidity :: ReaderT Common.Handle IO a -> IO a
run         x = Common.with $ Common.connectAny      >> x
runLLVM     x = Common.with $ Common.connectLLVM     >> x
runTimidity x = Common.with $ Common.connectTimidity >> x


pass,
   transpose,
   reverse,
   latch,
   groupLatch,
   delay,
   delayAdd,
   delayTranspose,
   cycleUp,
   cycleUpAuto,
   pingPong,
   pingPongAuto,
   binary,
   crossSum,
   bruijn,
   random,
   randomInversions,
   serialCycleUp,
   split,
   splitPattern,
   cyclePrograms,
   sweep,
   guitar,
   snapSelect,
   continuousSelect :: ReaderT Common.Handle IO ()


time :: Rational -> Time.T
time = Time.cons "example"

pass = Seq.run id
transpose = Seq.run $ RBU.mapMaybe $ Common.transpose 2
reverse = Seq.run $ RBU.mapMaybe $ Common.reverse
-- works, but does not interact nicely with AllNotesOff
-- latch = Seq.run (Seq.bypass Common.maybeNote (fst . Seq.latch))
latch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.latch))
groupLatch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.groupLatch))
delay = Seq.run (Seq.delay $ time 0.2)
delayAdd = Seq.run (Seq.delayAdd $ time 0.2)
delayTranspose = Seq.run $ \ evs ->
   let proc p dt =
          Seq.delay (time dt) $
          RBU.mapMaybe (Common.transpose p) evs
       evs1 = proc  4 0.2
       evs2 = proc  7 0.4
       evs3 = proc 12 0.6
   in foldl RB.union (fmap Common.now evs) [evs1, evs2, evs3]

getTempo ::
   (Check.C ev) =>
   RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev)
getTempo =
   uncurry Seq.tempoCtrl Common.defaultTempoCtrl
      (time 0.15) (time 0.5, time 0.05)
{-
   pure 0.2
-}

pattern ::
   (KeySet.C set) =>
   set ->
   (forall t.
    (RBF.Frameworks t) =>
    RB.Behavior t set ->
    RB.Event t Time.Abs ->
    RB.Event t [NoteBoundary]) ->
   ReaderT Common.Handle IO ()
pattern set pat = Seq.runM $ \ times evs0 -> do
   let (tempo, evs1) = getTempo evs0
   beat <- Seq.beatVar times tempo
   return $
      Seq.bypass Common.maybeNoteExt
         (\notes ->
            pat (snd $ Seq.pressed set notes) beat) evs1


serialCycleUp
         = pattern (KeySet.serialLatch 4) (Pattern.cycleUp (pure 4))
cycleUp  = pattern KeySet.groupLatch (Pattern.cycleUp (pure 4))
pingPong = pattern KeySet.groupLatch (Pattern.pingPong (pure 4))
binary   = pattern KeySet.groupLatch Pattern.binaryLegato
crossSum = pattern KeySet.groupLatch (Pattern.crossSum (pure 4))
bruijn   = pattern KeySet.groupLatch (Pattern.bruijn 4 2)
random   = pattern KeySet.groupLatch Pattern.random
randomInversions
         = pattern KeySet.groupLatch Pattern.randomInversions

cycleUpAuto = pattern KeySet.groupLatch $
   \set -> Pattern.cycleUp (fmap KeySet.size set) set
pingPongAuto = pattern KeySet.groupLatch $
   \set -> Pattern.pingPong (fmap KeySet.size set) set

cycleUpOffset ::
   ReaderT Common.Handle IO ()
cycleUpOffset = Seq.runM $ \ times evs0 -> do
   let (tempo, evs1) = getTempo evs0
       n = 4
       range = 3 * fromIntegral n
       offset =
          fmap round $
          Seq.controllerLinear (channel 0) (controller 17)
             (0::Float) (-range,range) evs1
   beat <- Seq.beatVar times tempo
   return $
      Seq.bypass Common.maybeNoteExt
         (\notes ->
            Pattern.mono Pattern.selectFromOctaveChord
               (snd $ Seq.pressed KeySet.groupLatch notes)
               (pure (\o i -> mod (i-o) n + o)
                   <*> offset
                   <@> Pattern.cycleUpIndex (pure n) beat)) evs1


continuousSelect = Seq.runM $ \ _times evs ->
   fmap
      (Pattern.mono
         Pattern.selectFromOctaveChord
         (snd $ Seq.pressed KeySet.groupLatch $
          RBU.mapMaybe Common.maybeNoteExt evs)) $
   Seq.uniqueChanges $
   fmap round $
   Seq.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs

snapSelect = Seq.runM $ \ _times evs -> do
   Seq.snapSelect
      (snd $ Seq.pressed KeySet.groupLatch $ RBU.mapMaybe Common.maybeNoteExt evs)
      (Seq.controllerRaw (channel 0) (controller 17) 64 evs)
{-
   let ctrl = Seq.controllerRaw (channel 0) (controller 17) 64 evs
   Seq.bypass Common.maybeNoteExt
      (\notes ->
         Seq.snapSelect (snd $ Seq.pressed KeySet.groupLatch notes) ctrl) evs
-}

split = Seq.run $
   uncurry RB.union
   .
   mapFst
      (RBU.mapMaybe (Common.transpose 12)
       .
       fmap (Common.setChannel (channel 1)))
   .
   RBU.partition
      (\e ->
         (Common.checkChannel (channel 0 ==) e &&
          Common.checkPitch   (pitch 60 >) e) ||
         Common.checkController (controller 94 ==) e ||
         Common.checkController (controller 95 ==) e)


splitPattern = Seq.runM $ \ times evs0 -> do
   let (tempo, evs1) = getTempo evs0
   beat <- Seq.beatVar times tempo

   let checkLeft e = do
          bnd <- Common.maybeNoteExt e
          case bnd of
             NoteBoundaryExt (NoteBoundary (pit,_chan) _vel _on) -> do
                guard (pit < pitch 60)
                return bnd
             _ -> return bnd

   return $
      Seq.bypass checkLeft
         (\left ->
            fmap (mapMaybe (Common.transpose 12) . map Common.noteFromBnd) $
            Pattern.cycleUp (pure 4)
               (snd $ Seq.pressed KeySet.groupLatch left) beat)
         evs1
{-
           RBU.mapMaybe (Common.transpose 12) left)) beat
-}


cyclePrograms = Seq.runM $ \times evs -> return $
--   Seq.cyclePrograms (map program [13..17]) times evs
   RB.union
      (RB.filterJust $
       Seq.cycleProgramsDefer (time 0.1) (map program [13..17]) times evs)
      evs

sweep =
   Seq.runM $ \ _times evs ->
      let c = channel 0
          centerCC = controller 70
          depthCC = controller 17
          speedCC = controller 16
      in  fmap (RB.union
                   (RB.filterE (not. Common.checkController
                                        (flip elem [centerCC, depthCC, speedCC])) evs) .
                uncurry
                   (Seq.makeControllerLinear c centerCC
                      (Seq.controllerRaw c depthCC 64 evs)
                      (Seq.controllerRaw c centerCC 64 evs)))
          $
          Seq.sweep
             (time 0.01) (sin . (2*pi*))
             (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs)

guitar =
   Seq.run $
      Seq.bypass Common.maybeNoteExt $ \notes ->
      let (trigger, keys) =
             RBU.partitionMaybe
                (\note ->
                   case note of
                      NoteBoundaryExt (NoteBoundary (pit,_chan) _vel on) -> do
                         guard $ pit == pitch 84
                         return on
                      _ -> Nothing)
                notes
      in  Seq.guitar (time 0.03) (snd $ Seq.pressed KeySet.groupLatch keys) trigger

trainer ::
   (Random.RandomGen g) =>
   g -> ReaderT Common.Handle IO ()
trainer g =
   Seq.runM $ \ times evs ->
      fmap (RB.union (fmap Common.singletonBundle evs)) $
      Seq.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs