Example.hs

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

import qualified Reactive.Banana.ALSA.Sequencer as Seq
import qualified Reactive.Banana.ALSA.Common as Common
import qualified Reactive.Banana.ALSA.Time as AlsaTime

import qualified Reactive.Banana.MIDI.Training as Training
import qualified Reactive.Banana.MIDI.Pattern as Pattern
import qualified Reactive.Banana.MIDI.Controller as Ctrl
import qualified Reactive.Banana.MIDI.Pitch as Pitch
import qualified Reactive.Banana.MIDI.KeySet as KeySet
import qualified Reactive.Banana.MIDI.Process as Process
import qualified Reactive.Banana.MIDI.Note as Note
import qualified Reactive.Banana.MIDI.Time as Time
import Reactive.Banana.MIDI.Common
          (PitchChannel,
           program, channel, pitch, controller,
           singletonBundle, now, )

import qualified Reactive.Banana.MIDI.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.ALSA.Check as Check
import qualified Sound.MIDI.ALSA.Query as Query ()
import qualified Sound.MIDI.ALSA.Construct as Construct ()
import qualified Sound.ALSA.Sequencer.Event as Event
import Sound.MIDI.Message.Channel.Voice (Velocity, )

import qualified System.Random as Random

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

import Prelude hiding (reverse, )


run, runLLVM, runTimidity :: ReaderT Seq.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 Seq.Handle IO ()


time :: Rational -> AlsaTime.RelativeSeconds
time = Time.relative "example" . Time.Seconds

ticks ::
   (RBF.Frameworks t) =>
   Rational -> Seq.Reactor t AlsaTime.RelativeTicks
ticks = Time.ticksFromSeconds . time

{-
stranspose ::
   (Query.C msg, Construct.C msg) => Int -> msg -> Maybe msg
-}
stranspose :: Int -> Event.Data -> Maybe Event.Data
stranspose d = Note.liftMaybe $ Note.transpose d

pass = Seq.run id
transpose = Seq.run $ RBU.mapMaybe $ stranspose 2
reverse = Seq.run $ RBU.mapMaybe $ Note.liftMaybe Note.reverse
-- works, but does not interact nicely with Note.AllOff
-- latch = Seq.run (Seq.bypass Common.maybeNote (fst . Seq.latch))
latch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.latch))
groupLatch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.groupLatch))
delay = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delay dt evs
delayAdd = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delayAdd dt evs
delayTranspose = Seq.runM $ \ _times evs -> do
   let proc p dt = do
          tk <- ticks dt
          return $
             Process.delay tk $
             RBU.mapMaybe (stranspose p) evs
   fmap (foldl RB.union (fmap now evs)) $ sequence $
      proc  4 0.2 :
      proc  7 0.4 :
      proc 12 0.6 :
      []

getTempo ::
   (Check.C ev, RBF.Frameworks t) =>
   RB.Event t ev ->
   Seq.Reactor t (RB.Behavior t AlsaTime.RelativeTicks, RB.Event t ev)
getTempo ctrl =
   liftM3 (uncurry Process.tempoCtrl Ctrl.tempoDefault)
      (ticks 0.15) (liftM2 (,) (ticks 0.5) (ticks 0.05)) (return ctrl)
{-
   pure 0.2
-}

pattern ::
   (KeySet.C set) =>
   set PitchChannel Velocity ->
   (forall t.
    (RBF.Frameworks t) =>
    RB.Behavior t (set PitchChannel Velocity) ->
    RB.Event t AlsaTime.AbsoluteTicks ->
    RB.Event t [Note.Boundary PitchChannel Velocity]) ->
   ReaderT Seq.Handle IO ()
pattern set pat = Seq.runM $ \ times evs0 -> do
   (tempo, evs1) <- getTempo evs0
   beat <- Process.beatVar times tempo
   return $
      Seq.bypass Note.maybeBndExt
         (\notes ->
            pat (snd $ Process.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 Seq.Handle IO ()
cycleUpOffset = Seq.runM $ \ times evs0 -> do
   (tempo, evs1) <- getTempo evs0
   let n = 4
       range = 3 * fromIntegral n
       offset =
          fmap round $
          Process.controllerLinear (channel 0) (controller 17)
             (0::Float) (-range,range) evs1
   beat <- Process.beatVar times tempo
   return $
      Seq.bypass Note.maybeBndExt
         (\notes ->
            Pattern.mono Pattern.selectFromOctaveChord
               (snd $ Process.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 $ Process.pressed KeySet.groupLatch $
          RBU.mapMaybe Note.maybeBndExt evs)) $
   Process.uniqueChanges $
   fmap round $
   Process.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs

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

split = Seq.run $
   uncurry RB.union
   .
   mapFst
      (RBU.mapMaybe (stranspose 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
   (tempo, evs1) <- getTempo evs0
   beat <- Process.beatVar times tempo

   let checkLeft e = do
          bnd <- Note.maybeBndExt e
          case bnd of
             Note.BoundaryExt (Note.Boundary pc _vel _on) -> do
                guard (Pitch.extract pc < pitch 60)
                return bnd
             _ -> return bnd

   return $
      Seq.bypass checkLeft
         (\left ->
            fmap (mapMaybe (stranspose 12 . Note.fromBnd)) $
            Pattern.cycleUp (pure 4)
               (snd $ Process.pressed KeySet.groupLatch left) beat)
         evs1
{-
           RBU.mapMaybe (stranspose 12) left)) beat
-}


cyclePrograms = Seq.runM $ \times evs -> do
--   Seq.cyclePrograms (map program [13..17]) times evs
   defer <- Time.ticksFromSeconds $ time 0.1
   return $ RB.union
      (RB.filterJust $
       Process.cycleProgramsDefer defer (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
                   (Process.makeControllerLinear c centerCC
                      (Process.controllerRaw c depthCC 64 evs)
                      (Process.controllerRaw c centerCC 64 evs)))
          $
          Process.sweep
             (time 0.01) (sin . (2*pi*))
             (Process.controllerExponential c speedCC 0.3 (0.1, 1) evs)

guitar =
   Seq.runM $ \ _times evs ->
      (\f -> fmap (flip f evs) (ticks 0.03)) $ \del ->
      Seq.bypass Note.maybeBndExt $ \notes ->
      let (trigger, keys) =
             RBU.partitionMaybe
                (\note ->
                   case note of
                      Note.BoundaryExt (Note.Boundary pc _vel on) -> do
                         guard $ Pitch.extract pc == pitch 84
                         return on
                      _ -> Nothing)
                notes
      in  (Process.guitar del
                :: RB.Behavior t (KeySet.GroupLatch PitchChannel Velocity) ->
                   RB.Event t Bool -> RB.Event t Common.EventDataBundle)
             (snd $ Process.pressed KeySet.groupLatch keys) trigger

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