Example.hs

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.Common as Common
import Reactive.Banana.ALSA.Common (program, channel, pitch, controller, )

import qualified Reactive.Banana.Model as RB

import qualified Sound.MIDI.ALSA as MALSA
import Data.Accessor.Basic ((^.), )

import qualified Sound.ALSA.Sequencer.Event as Event

import qualified System.Random as Random

import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, )

import Prelude hiding (reverse, )


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


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


pass = Seq.run id
transpose = Seq.run $ Seq.mapMaybe $ Common.transpose 2
reverse = Seq.run $ Seq.mapMaybe $ Common.reverse
latch = Seq.run (fst . Seq.latch)
groupLatch = Seq.run (fst . Seq.pressed KeySet.groupLatch)
delay = Seq.run (Seq.delay 0.2)
delayAdd = Seq.run (Seq.delayAdd 0.2)
delayTranspose = Seq.run $ \ evs ->
   let proc p dt =
          Seq.delay dt $
          Seq.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]

pattern ::
   (KeySet.C set) =>
   set -> Pattern.Mono set i -> ReaderT Common.Handle IO ()
pattern set pat = Seq.runM $ \ _times evs -> do
{-
   let tempo = Seq.constant 0.2
-}
   let tempo =
          uncurry Seq.tempoCtrl Common.defaultTempoCtrl 0.15 (0.5,0.05) evs
   fmap (RB.union
           (fmap Common.singletonBundle $
            RB.filterE (not . Common.checkPitch (const True)) evs)) $
      Seq.patternQuant 0.1 pat tempo (snd $ Seq.pressed set evs)

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

cyclePrograms = Seq.runM $ \times evs -> return $
--   Seq.cyclePrograms (map program [13..17]) times evs
   RB.union
      (RB.filterJust $
       Seq.cycleProgramsDefer 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
             0.01 (sin . (2*pi*))
             (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs)

guitar =
   Seq.run $ \ evs ->
      let (trigger, keys) =
             Seq.partitionMaybe
                (\ev ->
                   case ev of
                      Event.NoteEv notePart note -> do
                         guard $ (note ^. MALSA.notePitch) == pitch 84
                         return $ notePart == Event.NoteOn
                      _ -> Nothing)
                evs
      in  Seq.guitar 0.03 (snd $ Seq.pressed KeySet.groupLatch keys) trigger
          `RB.union`
          fmap Common.singletonBundle
             (RB.filterE (not . Common.checkPitch (const True)) evs)

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) 0.5 0.3 (Training.all g) times evs