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
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)
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 (io) 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)
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
cyclePrograms = Seq.runM $ \times evs -> return $
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