reactive-balsa (empty) → 0.0
raw patch · 12 files changed
+2591/−0 lines, 12 filesdep +alsa-coredep +alsa-seqdep +basesetup-changed
Dependencies added: alsa-core, alsa-seq, base, containers, data-accessor, data-accessor-transformers, event-list, midi, midi-alsa, non-negative, random, reactive-banana, transformers, utility-ht
Files
- LICENSE +31/−0
- Setup.lhs +3/−0
- reactive-balsa.cabal +87/−0
- src/Reactive/Banana/ALSA/Common.hs +745/−0
- src/Reactive/Banana/ALSA/DeBruijn.hs +133/−0
- src/Reactive/Banana/ALSA/Example.hs +139/−0
- src/Reactive/Banana/ALSA/Guitar.hs +37/−0
- src/Reactive/Banana/ALSA/KeySet.hs +257/−0
- src/Reactive/Banana/ALSA/Pattern.hs +291/−0
- src/Reactive/Banana/ALSA/Sequencer.hs +714/−0
- src/Reactive/Banana/ALSA/Training.hs +110/−0
- src/Reactive/Banana/ALSA/Trie.hs +44/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2012, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ reactive-balsa.cabal view
@@ -0,0 +1,87 @@+Name: reactive-balsa+Version: 0.0+License: BSD3+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+-- Homepage: http://www.haskell.org/haskellwiki/MIDI+Category: Sound, Music+Build-Type: Simple+Synopsis: Programmatically edit MIDI events via ALSA and reactive-banana+Description:+ MIDI is the Musical Instrument Digital Interface,+ ALSA is the Advanced Linux Sound Architecture.+ This package allows to manipulate a sequence of MIDI events via ALSA.+ It is intended to be plugged as a playing assistant+ between a MIDI input device+ (e.g. a keyboard or a controller bank)+ and a MIDI controlled synthesizer+ (e.g. a software synthesizer or an external synthesizer).+ For software synthesizers see the Haskell packages+ @synthesizer-alsa@, @synthesizer-llvm@, @supercollider-midi@,+ @hsc3@, @YampaSynth@+ or the C packages @fluidsynth@ and @Timidity@.+ .+ Applications include:+ Remapping of channels, controller, instruments, keys,+ Keyboard splitting, Conversion from notes to controllers, Latch mode,+ Convert parallel chords to serial patterns,+ Automated change of MIDI controllers,+ Delay and echo.+ .+ It is intended that you write programs for MIDI stream manipulation.+ It is not intended to provide an executable program+ with all the functionality available+ in a custom programming interface.+ It is most fun to play with the stream editors in GHCi.+ However we provide an example module that demonstrates various effects.+Tested-With: GHC==6.12.3+Cabal-Version: >=1.6+Build-Type: Simple+Source-Repository head+ type: darcs+ location: http://code.haskell.org/~thielema/reactive-balsa/++Source-Repository this+ type: darcs+ location: http://code.haskell.org/~thielema/reactive-balsa/+ tag: 0.0++Flag splitBase+ description: Choose the new smaller, split-up base package.++Library+ Build-Depends:+ reactive-banana >=0.4.3 && <0.5,+ midi-alsa >=0.2 && <0.3,+ midi >=0.2 && <0.3,+ alsa-seq >=0.5 && <0.6,+ alsa-core >=0.5 && <0.6,+ event-list >=0.1 && < 0.2,+ non-negative >=0.1 && <0.2,+ data-accessor-transformers >=0.2.1 && <0.3,+ data-accessor >=0.2.1 && <0.3,+ utility-ht >=0.0.5 && <0.1,+ containers >=0.2 && <0.5,+ transformers >=0.2 && <0.3+ If flag(splitBase)+ Build-Depends:+ random >=1 && <2,+ base >= 2 && <5+ Else+ Build-Depends:+ base >= 1.0 && < 2++ GHC-Options: -Wall+ Hs-Source-Dirs: src+ Exposed-Modules:+ Reactive.Banana.ALSA.Sequencer+ Reactive.Banana.ALSA.Example+ Reactive.Banana.ALSA.KeySet+ Reactive.Banana.ALSA.Pattern+ Reactive.Banana.ALSA.Guitar+ Reactive.Banana.ALSA.Training+ Reactive.Banana.ALSA.Common+ Other-Modules:+ Reactive.Banana.ALSA.DeBruijn+ Reactive.Banana.ALSA.Trie
+ src/Reactive/Banana/ALSA/Common.hs view
@@ -0,0 +1,745 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Reactive.Banana.ALSA.Common where++import qualified Sound.ALSA.Sequencer as SndSeq+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.Port.Info as PortInfo+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer.RealTime as RealTime++import qualified Sound.MIDI.ALSA as MALSA+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode++import Sound.MIDI.ALSA (normalNoteFromEvent, )+import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )++import qualified Data.EventList.Relative.TimeBody as EventList++import Data.Accessor.Basic ((^.), (^=), )++import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (mapFst, mapSnd, )++import qualified Data.Map as Map++import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Reader as Reader+import Control.Monad.Trans.Reader (ReaderT, )++import qualified Numeric.NonNegative.Class as NonNeg++import qualified Data.Monoid as Mn+import Data.Ratio ((%), )+import Data.Word (Word8, )+import Data.Int (Int32, )++import Prelude hiding (init, filter, reverse, )+++-- * helper functions++data Handle =+ Handle {+ sequ :: SndSeq.T SndSeq.DuplexMode,+ client :: Client.T,+ portPublic, portPrivate :: Port.T,+ queue :: Queue.T+ }++init :: IO Handle+init = do+ h <- SndSeq.open SndSeq.defaultName SndSeq.Block+ Client.setName h "Haskell-Filter"+ c <- Client.getId h+ ppublic <-+ Port.createSimple h "inout"+ (Port.caps [Port.capRead, Port.capSubsRead,+ Port.capWrite, Port.capSubsWrite])+ Port.typeMidiGeneric+ pprivate <-+ Port.createSimple h "private"+ (Port.caps [Port.capRead, Port.capWrite])+ Port.typeMidiGeneric+ q <- Queue.alloc h+ let hnd = Handle h c ppublic pprivate q+ Reader.runReaderT setTimeStamping hnd+ return hnd++exit :: Handle -> IO ()+exit h = do+ _ <- Event.outputPending (sequ h)+ Queue.free (sequ h) (queue h)+ Port.delete (sequ h) (portPublic h)+ Port.delete (sequ h) (portPrivate h)+ SndSeq.close (sequ h)++with :: ReaderT Handle IO a -> IO a+with f =+ SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do+ Client.setName h "Haskell-Filter"+ c <- Client.getId h+ Port.withSimple h "inout"+ (Port.caps [Port.capRead, Port.capSubsRead,+ Port.capWrite, Port.capSubsWrite])+ Port.typeMidiGeneric $ \ppublic -> do+ Port.withSimple h "private"+ (Port.caps [Port.capRead, Port.capWrite])+ Port.typeMidiGeneric $ \pprivate -> do+ Queue.with h $ \q ->+ flip Reader.runReaderT (Handle h c ppublic pprivate q) $+ setTimeStamping >> f++-- | make ALSA set the time stamps in incoming events+setTimeStamping :: ReaderT Handle IO ()+setTimeStamping = Reader.ReaderT $ \h -> do+ info <- PortInfo.get (sequ h) (portPublic h)+ PortInfo.setTimestamping info True+ PortInfo.setTimestampReal info True+ PortInfo.setTimestampQueue info (queue h)+ PortInfo.set (sequ h) (portPublic h) info+++startQueue :: ReaderT Handle IO ()+startQueue = Reader.ReaderT $ \h -> do+ Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing+ _ <- Event.drainOutput (sequ h)+ return ()+++connect :: String -> String -> ReaderT Handle IO ()+connect fromName toName = Reader.ReaderT $ \h -> do+ from <- Addr.parse (sequ h) fromName+ to <- Addr.parse (sequ h) toName+ SndSeq.connectFrom (sequ h) (portPublic h) from+ SndSeq.connectTo (sequ h) (portPublic h) to++connectTimidity :: ReaderT Handle IO ()+connectTimidity =+ connect "ReMOTE" "TiMidity"+-- connect "E-MU Xboard61" "TiMidity"++connectLLVM :: ReaderT Handle IO ()+connectLLVM =+-- connect "USB Midi Cable" "Haskell-LLVM-Synthesizer"+ connect "E-MU Xboard61" "Haskell-LLVM-Synthesizer"+-- connect "ReMOTE SL" "Haskell-LLVM-Synthesizer"+-- connect "ReMOTE SL" "Haskell-Synthesizer"++connectSuperCollider :: ReaderT Handle IO ()+connectSuperCollider =+ connect "E-MU Xboard61" "Haskell-Supercollider"++++-- * send single events++sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()+sendNote chan dur vel pit =+ let note = simpleNote chan pit vel+ t = incTime dur 0+ in do outputEvent 0 (Event.NoteEv Event.NoteOn note)+ outputEvent t (Event.NoteEv Event.NoteOff note)++sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()+sendKey chan noteOn vel pit =+ outputEvent 0 $+ Event.NoteEv+ (if noteOn then Event.NoteOn else Event.NoteOff)+ (simpleNote chan pit vel)++sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()+sendController chan ctrl val =+ outputEvent 0 $+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent chan ctrl (fromIntegral val)++sendProgram :: Channel -> Program -> ReaderT Handle IO ()+sendProgram chan pgm =+ outputEvent 0 $+ Event.CtrlEv Event.PgmChange $+ MALSA.programChangeEvent chan pgm++sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()+sendMode chan mode =+ outputEvent 0 $+ Event.CtrlEv Event.Controller $+ MALSA.modeEvent chan mode+++-- * constructors++channel :: Int -> Channel+channel = ChannelMsg.toChannel++pitch :: Int -> Pitch+pitch = VoiceMsg.toPitch++velocity :: Int -> Velocity+velocity = VoiceMsg.toVelocity++controller :: Int -> Controller+controller = VoiceMsg.toController++program :: Int -> Program+program = VoiceMsg.toProgram+++normalVelocity :: VoiceMsg.Velocity+normalVelocity = VoiceMsg.normalVelocity++++-- * time++{- |+The 'Time' types are used instead of floating point types,+because the latter ones caused unpredictable 'negative number' errors.+The denominator must always be a power of 10,+this way we can prevent unlimited grow of denominators.+-}+type TimeAbs = Rational+newtype Time = Time {deconsTime :: Rational}+ deriving (Show, Eq, Ord, Num, Fractional)++consTime :: String -> Rational -> Time+consTime msg x =+ if x>=0+ then Time x+ else error $ msg ++ ": negative number"++incTime :: Time -> TimeAbs -> TimeAbs+incTime dt t = t + deconsTime dt++scaleTimeCeiling :: Double -> Time -> Time+scaleTimeCeiling k (Time t) =+ Time $ ceiling (toRational k * t * nano) % nano++nano :: Num a => a+nano = 1000^(3::Int)++instance Mn.Monoid Time where+ mempty = Time 0+ mappend (Time x) (Time y) = Time (x+y)++instance NonNeg.C Time where+ split = NonNeg.splitDefault deconsTime Time+++timeFromStamp :: Event.TimeStamp -> TimeAbs+timeFromStamp t =+ case t of+ Event.RealTime rt ->+ RealTime.toInteger rt % nano+-- _ -> 0,+ _ -> error "unsupported time stamp type"++stampFromTime :: TimeAbs -> Event.TimeStamp+stampFromTime t =+ Event.RealTime (RealTime.fromInteger (round (t*nano)))++++defaultTempoCtrl :: (Channel,Controller)+defaultTempoCtrl =+ (ChannelMsg.toChannel 0, VoiceMsg.toController 16)++++-- * events++{- |+This class unifies several ways of handling multiple events at once.+-}+class Events ev where+ flattenEvents :: ev -> [Future Event.Data]++instance Events Event.Data where+ flattenEvents ev = [Future 0 ev]++instance Events ev => Events (Future ev) where+ flattenEvents (Future dt ev) =+ map (\(Future t e) -> Future (t+dt) e) $+ flattenEvents ev++instance Events ev => Events (Maybe ev) where+ flattenEvents ev = maybe [] flattenEvents ev++instance Events ev => Events [ev] where+ flattenEvents = concatMap flattenEvents++instance (Events ev0, Events ev1) => Events (ev0,ev1) where+ flattenEvents (ev0,ev1) = flattenEvents ev0 ++ flattenEvents ev1++instance (Events ev0, Events ev1, Events ev2) => Events (ev0,ev1,ev2) where+ flattenEvents (ev0,ev1,ev2) =+ flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2+++makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T+makeEvent h t e =+ Event.Cons+ { Event.highPriority = False+ , Event.tag = 0+ , Event.queue = queue h+ , Event.timestamp = stampFromTime t+ , Event.source = Addr.Cons (client h) (portPublic h)+ , Event.dest = Addr.subscribers+ , Event.body = e+ }++makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T+makeEcho h t c =+ Event.Cons+ { Event.highPriority = False+ , Event.tag = 0+ , Event.queue = queue h+ , Event.timestamp = stampFromTime t+ , Event.source = Addr.Cons (client h) (portPrivate h)+ , Event.dest = Addr.Cons (client h) (portPrivate h)+ , Event.body = Event.CustomEv Event.Echo c+ }+++outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()+outputEvent t ev = Reader.ReaderT $ \h ->+ Event.output (sequ h) (makeEvent h t ev) >>+ Event.drainOutput (sequ h) >>+ return ()+++simpleNote :: Channel -> Pitch -> Velocity -> Event.Note+simpleNote c p v =+ Event.simpleNote+ (MALSA.fromChannel c)+ (MALSA.fromPitch p)+ (MALSA.fromVelocity v)+++{- |+The times are relative to the start time of the bundle+and do not need to be ordered.+-}+data Future a = Future {futureTime :: Time, futureData :: a}+type Bundle a = [Future a]+type EventBundle = Bundle Event.T+type EventDataBundle = Bundle Event.Data++singletonBundle :: a -> Bundle a+singletonBundle ev = [Future 0 ev]++immediateBundle :: [a] -> Bundle a+immediateBundle = map now++now :: a -> Future a+now = Future 0++instance Functor Future where+ fmap f (Future dt a) = Future dt $ f a+++-- * effects++{- |+Transpose a note event by the given number of semitones.+Non-note events are returned without modification.+If by transposition a note leaves the range of representable MIDI notes,+then we return Nothing.+-}+transpose ::+ Int -> Event.Data -> Maybe Event.Data+transpose d e =+ case e of+ Event.NoteEv notePart note ->+ fmap (\p ->+ Event.NoteEv notePart $+ (MALSA.notePitch ^= p) note) $+ increasePitch d $+ note ^. MALSA.notePitch+ _ -> Just e++{- |+Swap order of keys.+Non-note events are returned without modification.+If by reversing a note leaves the range of representable MIDI notes,+then we return Nothing.+-}+reverse ::+ Event.Data -> Maybe Event.Data+reverse e =+ case e of+ Event.NoteEv notePart note ->+ fmap (\p ->+ Event.NoteEv notePart $+ (MALSA.notePitch ^= p) note) $+ maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $+ note ^. MALSA.notePitch+ _ -> Just e++setChannel ::+ Channel -> Event.Data -> Event.Data+setChannel chan e =+ case e of+ Event.NoteEv notePart note ->+ Event.NoteEv notePart $+ (MALSA.noteChannel ^= chan) note+ Event.CtrlEv ctrlPart ctrl ->+ Event.CtrlEv ctrlPart $+ (MALSA.ctrlChannel ^= chan) ctrl+ _ -> e++{- |+> > replaceProgram [1,2,3,4] 5 [10,11,12,13]+> (True,[10,11,2,13])+-}+replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32])+replaceProgram (n:ns) pgm pt =+ let (p,ps) =+ case pt of+ [] -> (0,[])+ (x:xs) -> (x,xs)+ in if pgm<n+ then (True, pgm:ps)+ else mapSnd (p:) $+ replaceProgram ns (pgm-n) ps+replaceProgram [] _ ps = (False, ps)++programFromBanks :: [Int32] -> [Int32] -> Int32+programFromBanks ns ps =+ foldr (\(n,p) s -> p+n*s) 0 $+ zip ns ps++{- |+Interpret program changes as a kind of bank switches+in order to increase the range of instruments+that can be selected via a block of patch select buttons.++@programAsBanks ns@ divides the first @sum ns@ instruments+into sections of sizes @ns!!0, ns!!1, ...@.+Each program in those sections is interpreted as a bank in a hierarchy,+where the lower program numbers are the least significant banks.+Programs from @sum ns@ on are passed through as they are.+@product ns@ is the number of instruments+that you can address using this trick.+In order to avoid overflow it should be less than 128.++E.g. @programAsBanks [n,m]@ interprets subsequent program changes to+@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)+as a program change to @b*n+a@.+@programAsBanks [8,8]@ allows to select 64 instruments+by 16 program change buttons,+whereas @programAsBanks [8,4,4]@+allows to address the full range of MIDI 128 instruments+with the same number of buttons.+-}+programsAsBanks ::+ [Int32] ->+ Event.Data -> State.State [Int32] Event.Data+programsAsBanks ns e =+ case e of+ Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->+ let pgm = Event.ctrlValue ctrl+ (valid, ps1) = replaceProgram ns pgm ps0+ in (Event.CtrlEv Event.PgmChange $+ ctrl{Event.ctrlValue =+ if valid+ then programFromBanks ns ps1+ else pgm},+ ps1)+ _ -> return e+++nextProgram :: Event.Note -> State.State [Program] (Maybe Event.Data)+nextProgram note =+ State.state $ \pgms ->+ case pgms of+ pgm:rest ->+ (Just $+ Event.CtrlEv Event.PgmChange $+ Event.Ctrl {+ Event.ctrlChannel = Event.noteChannel note,+ Event.ctrlParam = 0,+ Event.ctrlValue = MALSA.fromProgram pgm},+ rest)+ [] -> (Nothing, [])++seekProgram :: Int -> Program -> State.State [Program] (Maybe Event.Data)+seekProgram maxSeek pgm =+ fmap (const Nothing) $+ State.modify $+ uncurry (++) .+ mapFst (dropWhile (pgm/=)) .+ splitAt maxSeek+++{- |+Before every note switch to another instrument+according to a list of programs given as state of the State monad.+I do not know how to handle multiple channels in a reasonable way.+Currently I just switch the instrument independent from the channel,+and send the program switch to the same channel as the beginning note.+-}+traversePrograms ::+ Event.Data -> State.State [Program] (Maybe Event.Data)+traversePrograms e =+ case e of+ Event.NoteEv notePart note ->+ (case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> nextProgram note+ _ -> return Nothing)+ _ -> return Nothing++{- |+This function extends 'traversePrograms'.+It reacts on external program changes+by seeking an according program in the list.+This way we can reset the pointer into the instrument list.+However the search must be limited in order to prevent an infinite loop+if we receive a program that is not contained in the list.+-}+traverseProgramsSeek ::+ Int ->+ Event.Data -> State.State [Program] (Maybe Event.Data)+traverseProgramsSeek maxSeek e =+ case e of+ Event.NoteEv notePart note ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> nextProgram note+ _ -> return Nothing+ Event.CtrlEv Event.PgmChange ctrl ->+ seekProgram maxSeek (ctrl ^. MALSA.ctrlProgram)+ _ -> return Nothing++reduceNoteVelocity ::+ Word8 -> Event.Note -> Event.Note+reduceNoteVelocity decay note =+ note{Event.noteVelocity =+ let vel = Event.noteVelocity note+ in if vel==0+ then 0+ else vel - min decay (vel-1)}++delayAdd ::+ Word8 -> Time -> Event.Data -> EventDataBundle+delayAdd decay d e =+ singletonBundle e +++ case e of+ Event.NoteEv notePart note ->+ [Future d $+ Event.NoteEv notePart $+ reduceNoteVelocity decay note]+ _ -> []++++{- |+Map NoteOn events to a controller value.+This way you may play notes via the resonance frequency of a filter.+-}+controllerFromNote ::+ (Int -> Int) ->+ VoiceMsg.Controller ->+ Event.Data -> Maybe Event.Data+controllerFromNote f ctrl e =+ case e of+ Event.NoteEv notePart note ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn ->+ Just $+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent+ (note ^. MALSA.noteChannel)+ ctrl+ (fromIntegral $ f $+ fromIntegral $ VoiceMsg.fromPitch $+ note ^. MALSA.notePitch)+ Event.NoteOff -> Nothing+ _ -> Just e+ _ -> Just e+++type KeySet = Map.Map (Pitch, Channel) Velocity+type KeyQueue = [((Pitch, Channel), Velocity)]++eventsFromKey ::+ Time -> Time -> ((Pitch, Channel), Velocity) ->+ EventDataBundle+eventsFromKey start dur ((pit,chan), vel) =+ Future start (Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) :+ Future (Mn.mappend start dur)+ (Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :+ []+++maybePitch :: Int -> Maybe Pitch+maybePitch p =+ toMaybe+ (VoiceMsg.fromPitch minBound <= p &&+ p <= VoiceMsg.fromPitch maxBound)+ (VoiceMsg.toPitch p)++increasePitch :: Int -> Pitch -> Maybe Pitch+increasePitch d p =+ maybePitch $ d + VoiceMsg.fromPitch p++subtractPitch :: Pitch -> Pitch -> Int+subtractPitch p0 p1 =+ VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0+++-- | properFraction is useless for negative numbers+splitFraction :: (RealFrac a) => a -> (Int, a)+splitFraction x =+ case floor x of+ n -> (n, x - fromIntegral n)+++ctrlDur ::+ (Time, Time) -> Int -> Time+ctrlDur = ctrlDurExponential++ctrlDurLinear ::+ (Time, Time) -> Int -> Time+ctrlDurLinear (minDur, maxDur) val =+ minDur + (maxDur-minDur)+ * fromIntegral val / 127++ctrlDurExponential ::+ (Time, Time) -> Int -> Time+ctrlDurExponential (minDur, maxDur) val =+ minDur *+ Time+ (powerRationalFromFloat 10 3+ (fromRational $ deconsTime maxDur/deconsTime minDur :: Double)+ (fromIntegral val / 127))++{- |+Compute @base ** expo@+approximately to result type 'Rational'+such that the result has a denominator which is a power of @digitBase@+and a relative precision of numerator of @precision@ digits+with respect to @digitBase@-ary numbers.+-}+powerRationalFromFloat ::+ (Floating a, RealFrac a) =>+ Int -> Int -> a -> a -> Rational+powerRationalFromFloat digitBase precision base expo =+ let digitBaseFloat = fromIntegral digitBase+ {-+ It would be nice, if properFraction would warrant @0<=x<1@.+ Actually it can be @-1<x<=0@ in which case we lose one digit of precision.+ -}+ (n,x) = properFraction (logBase digitBaseFloat base * expo)+ frac = round (digitBaseFloat ** (x + fromIntegral precision))+ in fromInteger frac *+ fromIntegral digitBase ^^ (n-precision)+++fraction :: RealFrac a => a -> a+fraction x =+ let n = floor x+ in x - fromIntegral (n::Integer)++++{-+ctrlRange ::+ (RealFrac b) =>+ (b,b) -> (a -> b) -> (a -> Int)+ctrlRange (l,u) f x =+ round $+ limit (0,127) $+ 127*(f x - l)/(u-l)+-}+++-- * predicates - may be moved to midi-alsa package++controllerMatch ::+ Channel -> Controller -> Event.Ctrl -> Bool+controllerMatch chan ctrl param =+ Event.ctrlChannel param == MALSA.fromChannel chan &&+ Event.ctrlParam param == MALSA.fromController ctrl++checkChannel ::+ (Channel -> Bool) ->+ (Event.Data -> Bool)+checkChannel p e =+ case e of+ Event.NoteEv _notePart note ->+ p (note ^. MALSA.noteChannel)+ Event.CtrlEv Event.Controller ctrl ->+ p (ctrl ^. MALSA.ctrlChannel)+ _ -> False++checkPitch ::+ (Pitch -> Bool) ->+ (Event.Data -> Bool)+checkPitch p e =+ case e of+ Event.NoteEv _notePart note ->+ p (note ^. MALSA.notePitch)+ _ -> False++checkController ::+ (Controller -> Bool) ->+ (Event.Data -> Bool)+checkController p e =+ case e of+ Event.CtrlEv Event.Controller ctrlMode ->+ case ctrlMode ^. MALSA.ctrlControllerMode of+ MALSA.Controller ctrl _ -> p ctrl+ _ -> False+ _ -> False++checkMode ::+ (Mode.T -> Bool) ->+ (Event.Data -> Bool)+checkMode p e =+ case e of+ Event.CtrlEv Event.Controller ctrlMode ->+ case ctrlMode ^. MALSA.ctrlControllerMode of+ MALSA.Mode mode -> p mode+ _ -> False+ _ -> False++checkProgram ::+ (Program -> Bool) ->+ (Event.Data -> Bool)+checkProgram p e =+ case e of+ Event.CtrlEv Event.PgmChange ctrl ->+ p (ctrl ^. MALSA.ctrlProgram)+ _ -> False+++isAllNotesOff :: Event.Data -> Bool+isAllNotesOff =+ checkMode $ \mode ->+ mode == Mode.AllSoundOff ||+ mode == Mode.AllNotesOff++++-- * event list support++mergeStable ::+ (NonNeg.C time) =>+ EventList.T time body ->+ EventList.T time body ->+ EventList.T time body+mergeStable =+ EventList.mergeBy (\_ _ -> True)++mergeEither ::+ (NonNeg.C time) =>+ EventList.T time a ->+ EventList.T time b ->+ EventList.T time (Either a b)+mergeEither xs ys =+ mergeStable (fmap Left xs) (fmap Right ys)
+ src/Reactive/Banana/ALSA/DeBruijn.hs view
@@ -0,0 +1,133 @@+module Reactive.Banana.ALSA.DeBruijn where++import qualified Reactive.Banana.ALSA.Trie as Trie++import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe.HT (toMaybe, )++import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Data.Bits as Bits+import Data.Bits ((.&.), )++import Control.Monad (guard, replicateM, )++import Prelude hiding (all, )+++lexLeast :: Int -> Int -> [Int]+lexLeast n k =+ concat $+ filter ((0==) . mod k . length) $+ takeWhile (not . null) $+ iterate (nextLyndonWord n k) [0]++nextLyndonWord :: Int -> Int -> [Int] -> [Int]+nextLyndonWord n k =+ foldr+ (\x xs ->+ if null xs+ then (if x<n-1 then [x+1] else [])+ else x:xs) [] .+ take k . cycle+++{- |+All Bruijn sequences with a certain alphabet and a certain length of infixes.+-}+all :: Int -> Int -> [[Int]]+all n k =+ let start = replicate k 0+ go _ str 0 = do+ guard $ str==start+ return []+ go set str c = do+ d <- [0 .. n-1]+ let newStr = tail str ++ [d]+ guard $ Set.notMember newStr set+ rest <- go (Set.insert newStr set) newStr (c-1)+ return $ d:rest+ in map (ListHT.rotate (-k)) $+ go Set.empty start (n^k)++allMap :: Int -> Int -> [[Int]]+allMap n k =+ let start = replicate k 0+ delete d =+ Map.update (\set ->+ let newSet = Set.delete d set+ in toMaybe (not $ Set.null newSet) newSet)+ go [] _ = error "infixes must have positive length"+ go (_:str) todo =+ case Map.lookup str todo of+ Nothing -> do+ guard $ Map.null todo+ return []+ Just set -> do+ d <- Set.toList set+ rest <- go (str ++ [d]) $ delete d str todo+ return $ d:rest+ in map (take (n^k) . (start ++)) $+ go start $+ delete 0 (tail start) $+ Map.fromAscList $+ map (flip (,) $ Set.fromList [0 .. n-1]) $+ replicateM (k-1) [0 .. n-1]+++allTrie :: Int -> Int -> [[Int]]+allTrie n k =+ let start = replicate k 0+ go [] _ = error "infixes must have positive length"+ go (_:str) todo =+ case Trie.lookup str todo of+ Nothing -> do+ guard $ Trie.null todo+ return []+ Just set -> do+ d <- set+ rest <- go (str ++ [d]) $ Trie.delete d str todo+ return $ d:rest+ in map (take (n^k) . (start ++)) $+ go start $+ Trie.delete 0 (tail start) $+ Trie.full [0 .. n-1] [0 .. n-1] (k-1)+++allBits :: Int -> Int -> [[Int]]+allBits n k =+ let go code todo =+ let shiftedCode = mod (code*n) (n^k)+ in case Bits.shiftR todo shiftedCode .&. (2^n-1) of+ 0 -> do+ guard $ todo == 0+ return []+ set -> do+ d <- [0 .. n-1]+ guard $ Bits.testBit set d+ rest <-+ let newCode = shiftedCode + d+ in go newCode $ Bits.clearBit todo newCode+ return $ d:rest+ in map (take (n^k) . (replicate k 0 ++)) $+ go 0 $ (2^n^k-2 :: Integer)+++-- * tests++testLexLeast :: Int -> Int -> Bool+testLexLeast n k =+ lexLeast n k == head (allMap n k)++test :: Int -> Int -> [Int] -> Bool+test n k xs =+ replicateM k [0 .. n-1]+ ==+ (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)++testAll :: Int -> Int -> Bool+testAll n k =+ List.all (test n k) $ allMap n k
+ src/Reactive/Banana/ALSA/Example.hs view
@@ -0,0 +1,139 @@+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
+ src/Reactive/Banana/ALSA/Guitar.hs view
@@ -0,0 +1,37 @@+-- cf. Haskore/Guitar+module Reactive.Banana.ALSA.Guitar where++import qualified Reactive.Banana.ALSA.Common as Common+import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, )+import Data.Maybe (mapMaybe, )+++class Transpose pitch where+ getPitch :: pitch -> Pitch+ transpose :: Int -> pitch -> Maybe pitch++instance Transpose Pitch where+ getPitch = id+ transpose = Common.increasePitch+++mapChordToString ::+ (Transpose pitch, Ord pitch) =>+ [Pitch] -> [pitch] -> [pitch]+mapChordToString strings chord =+ mapMaybe (choosePitchForString chord) strings++choosePitchForString ::+ (Transpose pitch, Ord pitch) =>+ [pitch] -> Pitch -> Maybe pitch+choosePitchForString chord string =+ let roundDown x d = x - mod x d+ minAbove x =+ transpose+ (- roundDown (Common.subtractPitch string (getPitch x)) 12) x+ in maximum (map minAbove chord)++stringPitches :: [Pitch]+stringPitches =+ reverse $ map toPitch [40, 45, 50, 55, 59, 64]+-- reverse [(-2,E), (-2,A), (-1,D), (-1,G), (-1,B), (0,E)]
+ src/Reactive/Banana/ALSA/KeySet.hs view
@@ -0,0 +1,257 @@+module Reactive.Banana.ALSA.KeySet where++import qualified Reactive.Banana.ALSA.Common as Common++import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Sound.MIDI.ALSA as MALSA+import Sound.MIDI.ALSA (normalNoteFromEvent, )++-- import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )++import qualified Data.Accessor.Monad.Trans.State as AccState+-- import qualified Data.Accessor.Tuple as AccTuple+import qualified Data.Accessor.Basic as Acc+import Data.Accessor.Basic ((^.), (^=), )++import qualified Control.Monad.Trans.State as MS++import qualified Data.Map as Map+import qualified Data.Set as Set++import Data.Maybe (maybeToList, )+++{-+class C set where+ press :: Channel -> (Velocity, Pitch) -> set -> set+ release :: Channel -> (Velocity, Pitch) -> set -> set+ reset :: set -> set++change :: C set => Channel -> (Velocity, Pitch, Bool) -> set -> set+change chan (vel, pitch, True) = press chan (vel, pitch)+change chan (vel, pitch, False) = release chan (vel, pitch)+-}++class C set where+ reset :: MS.State set [(Event.NoteEv, Event.Note)]+ size :: set -> Int+ toList :: set -> [((Pitch, Channel), Velocity)]+ index :: Int -> set -> Maybe ((Pitch, Channel), Velocity)+ change ::+ Event.NoteEv -> Event.Note ->+ MS.State set [(Event.NoteEv, Event.Note)]++++newtype Pressed = Pressed {deconsPressed :: Map.Map (Pitch, Channel) Velocity}+ deriving (Show)++pressed :: Pressed+pressed = Pressed Map.empty++pressedAcc :: Acc.T Pressed (Map.Map (Pitch, Channel) Velocity)+pressedAcc = Acc.fromWrapper Pressed deconsPressed++instance C Pressed where+ reset = AccState.lift pressedAcc releasePlayedKeys+ size = Map.size . deconsPressed+ toList = Map.toAscList . deconsPressed+ index k (Pressed set) =+ case drop k $ Map.toAscList set of+ x:_ -> Just x+ _ -> Nothing+ change notePart note =+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ in do+ case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) ->+ MS.modify $ Pressed . Map.insert key vel . deconsPressed+ (Event.NoteOff, _) ->+ MS.modify $ Pressed . Map.delete key . deconsPressed+ _ -> return ()+ return [(notePart, note)]++++newtype Latch = Latch {deconsLatch :: Map.Map (Pitch, Channel) Velocity}+ deriving (Show)++latch :: Latch+latch = Latch Map.empty++latchAcc :: Acc.T Latch (Map.Map (Pitch, Channel) Velocity)+latchAcc = Acc.fromWrapper Latch deconsLatch++latchChange ::+ Event.NoteEv ->+ Event.Note ->+ MS.State Latch (Maybe (Event.NoteEv, Event.Note))+latchChange notePart note =+ case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ newNote =+ (MALSA.noteVelocity ^= vel) note+ isPressed <- MS.gets (Map.member key . deconsLatch)+ if isPressed+ then+ MS.modify (Latch . Map.delete key . deconsLatch) >>+ return (Just (Event.NoteOff, newNote))+ else+ MS.modify (Latch . Map.insert key vel . deconsLatch) >>+ return (Just (Event.NoteOn, newNote))+ (Event.NoteOff, _vel) ->+ return Nothing+ _ -> return Nothing++instance C Latch where+ reset = AccState.lift latchAcc releasePlayedKeys+ size = Map.size . deconsLatch+ toList = Map.toAscList . deconsLatch+ index k (Latch set) =+ case drop k $ Map.toAscList set of+ x:_ -> Just x+ _ -> Nothing+ change notePart note =+ fmap maybeToList $ latchChange notePart note++++data GroupLatch =+ GroupLatch {+ groupLatchPressed_ {- input -} :: Set.Set (Pitch, Channel),+ groupLatchPlayed_ {- output -} :: Map.Map (Pitch, Channel) Velocity+ } deriving (Show)++groupLatch :: GroupLatch+groupLatch = GroupLatch Set.empty Map.empty++groupLatchPressed :: Acc.T GroupLatch (Set.Set (Pitch, Channel))+groupLatchPressed =+ Acc.fromSetGet+ (\mp grp -> grp{groupLatchPressed_ = mp})+ groupLatchPressed_++groupLatchPlayed :: Acc.T GroupLatch (Map.Map (Pitch, Channel) Velocity)+groupLatchPlayed =+ Acc.fromSetGet+ (\mp grp -> grp{groupLatchPlayed_ = mp})+ groupLatchPlayed_++{- |+All pressed keys are latched until a key is pressed after a pause+(i.e. all keys released).+For aborting the pattern you have to send+a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.+-}+instance C GroupLatch where+ reset = AccState.lift groupLatchPlayed releasePlayedKeys+ size = Map.size . groupLatchPlayed_+ toList = Map.toAscList . groupLatchPlayed_+ index k set =+ case drop k $ Map.toAscList $ groupLatchPlayed_ set of+ x:_ -> Just x+ _ -> Nothing+ change notePart note =+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ in case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ pressd <- AccState.get groupLatchPressed+ noteOffs <-+ if Set.null pressd+ then AccState.lift groupLatchPlayed releasePlayedKeys+ else return []+ AccState.modify groupLatchPressed (Set.insert key)+ played <- AccState.get groupLatchPlayed+ noteOn <-+ if Map.member key played+ then+ return []+ else do+ AccState.modify groupLatchPlayed (Map.insert key vel)+ return [(Event.NoteOn, note)]+ return $+ noteOffs ++ noteOn+ (Event.NoteOff, _vel) ->+ AccState.modify groupLatchPressed (Set.delete key) >>+ return []+ _ -> return []++++data SerialLatch =+ SerialLatch {+ serialLatchSize_ :: Int,+ serialLatchCursor_ :: Int,+ serialLatchPlayed_ :: Map.Map Int ((Pitch, Channel), Velocity)+ } deriving (Show)++serialLatch :: Int -> SerialLatch+serialLatch num = SerialLatch num 0 Map.empty++serialLatchCursor :: Acc.T SerialLatch Int+serialLatchCursor =+ Acc.fromSetGet+ (\mp grp -> grp{serialLatchCursor_ = mp})+ serialLatchCursor_++serialLatchPlayed :: Acc.T SerialLatch (Map.Map Int ((Pitch, Channel), Velocity))+serialLatchPlayed =+ Acc.fromSetGet+ (\mp grp -> grp{serialLatchPlayed_ = mp})+ serialLatchPlayed_++++{- |+A key is hold until @n@ times further keys are pressed.+The @n@-th pressed key replaces the current one.+-}+instance C SerialLatch where+-- reset = AccState.lift serialLatchPlayed releasePlayedKeys+-- (0, Map.empty)+ reset =+ fmap (map (uncurry releaseKey) . Map.elems) $+ AccState.getAndModify serialLatchPlayed (const Map.empty)+ size = serialLatchSize_+ toList = Map.elems . serialLatchPlayed_+ index k = Map.lookup k . serialLatchPlayed_+ change notePart note =+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ in case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ n <- MS.gets serialLatchSize_+ k <- AccState.getAndModify serialLatchCursor (flip mod n . (1+))+ oldKey <- fmap (Map.lookup k) $ AccState.get serialLatchPlayed+ AccState.modify serialLatchPlayed (Map.insert k (key, vel))+ return $ maybeToList (fmap (uncurry releaseKey) oldKey)+ ++ [(notePart, note)]+ (Event.NoteOff, _vel) -> return []+ _ -> return [(notePart, note)]++releasePlayedKeys ::+ MS.State+ (Map.Map (Pitch, Channel) Velocity)+ [(Event.NoteEv, Event.Note)]+releasePlayedKeys =+ fmap (map (uncurry releaseKey) . Map.toList) $+ AccState.getAndModify Acc.self (const Map.empty)++releaseKey ::+ (Pitch, Channel) ->+ Velocity ->+ (Event.NoteEv, Event.Note)+releaseKey (p,c) vel =+ (Event.NoteOff, Common.simpleNote c p vel)
+ src/Reactive/Banana/ALSA/Pattern.hs view
@@ -0,0 +1,291 @@+module Reactive.Banana.ALSA.Pattern where++import qualified Reactive.Banana.ALSA.KeySet as KeySet+import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn++import Reactive.Banana.ALSA.Common+ (Time, EventDataBundle, eventsFromKey, splitFraction, increasePitch, )++import qualified Data.EventList.Relative.TimeBody as EventList+import Data.EventList.Relative.MixedBody ((/.), (./), )++import qualified Data.List.HT as ListHT+import qualified Data.List as List++import qualified System.Random as Rnd++import Control.Monad (guard, )++import Prelude hiding (init, filter, reverse, )++++-- * selectors++type Selector set i = i -> Time -> set -> EventDataBundle++data Mono set i = Mono (Selector set i) [i]+++data IndexNote i = IndexNote Int i+ deriving (Show, Eq, Ord)++item :: i -> Int -> IndexNote i+item i n = IndexNote n i++data Poly set i = Poly (Selector set i) (EventList.T Int [IndexNote i])+++{- |+Generate notes according to the key set,+where notes for negative and too large indices+are padded with keys that are transposed by octaves.+-}+selectFromOctaveChord ::+ KeySet.C set =>+ Selector set Int+selectFromOctaveChord d dur chord =+ maybe [] (eventsFromKey 0 dur) $ do+ let size = KeySet.size chord+ guard (size>0)+ let (q,r) = divMod d size+ ((pit,chan), vel) <- KeySet.index r chord+ transPitch <- increasePitch (12*q) pit+ return ((transPitch,chan), vel)++selectFromChord ::+ KeySet.C set =>+ Selector set Int+selectFromChord n dur chord =+ maybe [] (eventsFromKey 0 dur) (KeySet.index n chord)++selectFromChordRatio ::+ KeySet.C set =>+ Selector set Double+selectFromChordRatio d dur chord =+ selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) dur chord+++selectInversion ::+ KeySet.C set =>+ Selector set Double+selectInversion d dur chord =+ let makeNote octave ((pit,chan), vel) =+ maybe []+ (\pitchTrans -> eventsFromKey 0 dur ((pitchTrans,chan), vel))+ (increasePitch (octave*12) pit)+ (oct,p) = splitFraction d+ pivot = floor (p * fromIntegral (KeySet.size chord))+ (low,high) = splitAt pivot $ KeySet.toList chord+ in concatMap (makeNote oct) high +++ concatMap (makeNote (oct+1)) low++++-- * patterns++{- |+See Haskore/FlipSong++ flipSeq m !! n = cross sum of the m-ary representation of n modulo m.++ For m=2 this yields+ http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060+-}+flipSeq :: Int -> [Int]+flipSeq n =+ let incList m = map (\x -> mod (x+m) n)+ recourse y =+ let z = concatMap (flip incList y) [1 .. n-1]+ in z ++ recourse (y++z)+ in [0] ++ recourse [0]++{- |+@bruijn n k@ is a sequence with length n^k+where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes.+The function computes the lexicographically smallest of such sequences.+-}+bruijn :: Int -> Int -> [Int]+bruijn n k = DeBruijn.lexLeast n k+++cycleUp, cycleDown, pingPong, crossSum ::+ KeySet.C set =>+ Int -> Mono set Int+cycleUp number =+ Mono selectFromChord (cycle [0..(number-1)])+cycleDown number =+ Mono selectFromChord (cycle $ List.reverse [0..(number-1)])+pingPong number =+ Mono selectFromChord $+ cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)]+crossSum number =+ Mono selectFromChord (flipSeq number)++bruijnPat ::+ KeySet.C set =>+ Int -> Int -> Mono set Int+bruijnPat n k =+ Mono selectFromChord $ cycle $ bruijn n k++{-+We should increment the index at each step and wrap around according to current chord.+This way we avoid jumps in the pattern.++cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::+ KeySet.C set =>+ Mono set Integer+cycleUpAuto =+ Mono+ (\ d dur chord ->+ selectFromChord (mod d (fromIntegral $ length chord)) dur chord)+ [0..]+cycleDownAuto =+ Mono+ (\ d dur chord ->+ selectFromChord (mod d (fromIntegral $ length chord)) dur chord)+ [0,(-1)..]+pingPongAuto =+ Mono+ (\ d dur chord ->+ let s = 2 * (fromIntegral (length chord) - 1)+ m =+ if s<=0+ then 0+ else min (mod d s) (mod (-d) s)+ in selectFromChord m dur chord)+ [0..]+crossSumAuto =+ Mono+ (\ d dur chord ->+ let m = fromIntegral $ length chord+ s =+ if m <= 1+ then 0+ else sum $ decomposePositional m d+ in selectFromChord (mod s m) dur chord)+ [0..]+-}++binaryStaccato, binaryLegato, binaryAccident ::+ KeySet.C set => Poly set Int+{-+binary number Pattern.Mono:+ 0+ 1+ 0 1+ 2+ 0 2+ 1 2+ 0 1 2+ 3+-}+binaryStaccato =+ Poly+ selectFromChord+ (EventList.fromPairList $+ zip (0 : repeat 1) $+ map+ (map (IndexNote 1 . fst) .+ List.filter ((/=0) . snd) .+ zip [0..] .+ decomposePositional 2)+ [0..])++binaryLegato =+ Poly+ selectFromChord+ (EventList.fromPairList $+ zip (0 : repeat 1) $+ map+ (\m ->+ map (uncurry IndexNote) $+ List.filter (\(p,_i) -> mod m p == 0) $+ takeWhile ((<=m) . fst) $+ zip (iterate (2*) 1) [0..])+ [0..])++{-+This was my first try to implement binaryLegato.+It was not what I wanted, but it sounded nice.+-}+binaryAccident =+ Poly+ selectFromChord+ (EventList.fromPairList $+ zip (0 : repeat 1) $+ map+ (zipWith IndexNote (iterate (2*) 1) .+ map fst .+ List.filter ((/=0) . snd) .+ zip [0..] .+ decomposePositional 2)+ [0..])+++-- cf. htam:NumberTheory+decomposePositional :: Integer -> Integer -> [Integer]+decomposePositional b =+ let recourse 0 = []+ recourse x =+ let (q,r) = divMod x b+ in r : recourse q+ in recourse++cycleUpOctave ::+ KeySet.C set =>+ Int -> Mono set Int+cycleUpOctave number =+ Mono selectFromOctaveChord (cycle [0..(number-1)])++random, randomInversions ::+ KeySet.C set => Mono set Double+random =+ Mono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42))++randomInversions =+ inversions $+ map sum $+ ListHT.sliceVertical 3 $+ Rnd.randomRs (-1,1) $+ Rnd.mkStdGen 42++cycleUpInversions :: KeySet.C set => Int -> Mono set Double+cycleUpInversions n =+ inversions $ cycle $ take n $+ map (\i -> fromInteger i / fromIntegral n) [0..]++inversions :: KeySet.C set => [Double] -> Mono set Double+inversions rs =+ Mono selectInversion rs++++-- * tests++{-+We cannot use cycle function here, because we need to cycle a Body-Time list+which is incompatible to a Body-Body list,+even if the end is never reached.+-}+examplePolyTempo0 ::+ EventList.T Int [IndexNote Int]+examplePolyTempo0 =+ let pat =+ [item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /.+ [item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /.+ pat+ in 0 /. pat++examplePolyTempo1 ::+ EventList.T Int [IndexNote Int]+examplePolyTempo1 =+ let pat =+ [item 0 1] ./ 1 /.+ [item 2 1, item 3 1, item 4 1] ./ 1 /.+ [item 2 1, item 3 1, item 4 1] ./ 1 /.+ [item 1 1] ./ 1 /.+ [item 2 1, item 3 1, item 4 1] ./ 1 /.+ [item 2 1, item 3 1, item 4 1] ./ 1 /.+ pat+ in 0 /. pat
+ src/Reactive/Banana/ALSA/Sequencer.hs view
@@ -0,0 +1,714 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Reactive.Banana.ALSA.Sequencer where++import qualified Reactive.Banana.ALSA.Common as Common+import qualified Reactive.Banana.ALSA.Guitar as Guitar+import qualified Reactive.Banana.ALSA.Pattern as Pattern+import qualified Reactive.Banana.ALSA.KeySet as KeySet++import qualified Reactive.Banana as RB+import qualified Reactive.Banana.Model as RBM+import qualified Reactive.Banana.Implementation as RBI+import Reactive.Banana.Model ((<@>), )++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer.Address as Addr++import qualified Sound.MIDI.ALSA.Check as Check+import qualified Sound.MIDI.ALSA as MALSA+import Sound.MIDI.ALSA (normalNoteFromEvent, )++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice+ (Pitch, Controller, Velocity, Program, normalVelocity, )++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Absolute.TimeBody as EventListAbs++import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Tuple as AccTuple+import Data.Accessor.Basic ((^.), )++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Reader as MR+import Control.Monad.Trans.Reader (ReaderT(ReaderT), )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad.Fix (MonadFix, )+import Control.Monad (forever, when, )+import Control.Monad.HT ((<=<), )+import Control.Applicative (Applicative, pure, (<*>), )+import Data.Tuple.HT (mapPair, )+import Data.Ord.HT (comparing, limit, )+import Data.Maybe.HT (toMaybe, )+import Data.Word (Word32, )++import qualified Data.Map as Map+import qualified Data.List as List+import qualified Data.List.Match as Match++import Prelude hiding (sequence, )++++-- * make ALSA reactive++newtype Reactor a =+ Reactor {+ runReactor ::+ MR.ReaderT+ (RBI.AddHandler Event.T, Common.Handle)+ (MS.StateT Schedule RBI.NetworkDescription)+ a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++newtype Schedule = Schedule Word32+ deriving (Eq, Ord, Enum, Show)+++getHandle :: Reactor Common.Handle+getHandle = Reactor $ MR.asks snd++run ::+ (Common.Events ev) =>+ (RB.Event Event.Data -> RB.Event ev) ->+ ReaderT Common.Handle IO ()+run f =+ runM (\ _ts xs -> return $ f xs)++runM ::+ (Common.Events ev) =>+ (RB.Behavior Common.TimeAbs ->+ RB.Event Event.Data -> Reactor (RB.Event ev)) ->+ ReaderT Common.Handle IO ()+runM f = do+ Common.startQueue+ MR.ReaderT $ \h -> do+ (addEventHandler, runEventHandler) <- RBI.newAddHandler+ (addEchoHandler, runEchoHandler) <- RBI.newAddHandler+ (addTimeHandler, runTimeHandler) <- RBI.newAddHandler+ RBI.actuate <=< RBI.compile $ do+ time <-+ fmap (RB.stepper 0) $+ RBI.fromAddHandler addTimeHandler+ evs <-+ flip MS.evalStateT (Schedule 0)+ . flip MR.runReaderT (addEchoHandler, h)+ . runReactor+ . f time+ . fmap Event.body+ =<< RBI.fromAddHandler addEventHandler+ RBI.reactimate $+ pure (outputEvents h) <*> time <@> evs+ forever $ do+ ev <- Event.input (Common.sequ h)+ runTimeHandler $ Common.timeFromStamp $ Event.timestamp ev+ if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h)+ then debug "input: echo" >> runEchoHandler ev+ else debug "input: event" >> runEventHandler ev++outputEvents ::+ Common.Events evs =>+ Common.Handle -> Common.TimeAbs -> evs -> IO ()+outputEvents h time evs = do+ mapM_ (Event.output (Common.sequ h)) $+ map (\(Common.Future dt body) ->+ Common.makeEvent h (Common.incTime dt time) body) $+ Common.flattenEvents evs+ _ <- Event.drainOutput (Common.sequ h)+ return ()+++checkSchedule :: Schedule -> Event.T -> Bool+checkSchedule (Schedule sched) echo =+ maybe False (sched ==) $ do+ Event.CustomEv Event.Echo s <- Just $ Event.body echo+ let Event.Custom echoSchedule 0 0 = s+ return echoSchedule++scheduleData :: Schedule -> Event.Custom+scheduleData (Schedule sched) =+ Event.Custom sched 0 0++reactimate :: RB.Event (IO ()) -> Reactor ()+reactimate evs =+ Reactor $ MT.lift $ MT.lift $ RB.reactimate evs++sendEchos :: Common.Handle -> Schedule -> [Common.TimeAbs] -> IO ()+sendEchos h sched echos = do+ flip mapM_ echos $ \time ->+ Event.output (Common.sequ h) $+ Common.makeEcho h time (scheduleData sched)+ _ <- Event.drainOutput (Common.sequ h)+ debug "echos sent"++reserveSchedule ::+ Reactor (RB.Event Common.TimeAbs, [Common.TimeAbs] -> IO ())+reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do+ sched <- MS.get+ MS.modify succ+ eEcho <-+ MT.lift $+ fmap (fmap (Common.timeFromStamp . Event.timestamp) .+ RB.filterE (checkSchedule sched)) $+ RBI.fromAddHandler addH+ return (eEcho, sendEchos h sched)+++scheduleQueue :: Show a =>+ RB.Behavior Common.TimeAbs ->+ RB.Event (Common.Bundle a) -> Reactor (RB.Event a)+scheduleQueue times e = do+ (eEcho, send) <- reserveSchedule+ let -- maintain queue and generate Echo events+ remove echoTime =+ MS.state $ uncurry $ \_lastTime ->+ EventList.switchL+ (error "scheduleQueue: received more events than sent")+ (\(_t,x) xs ->+ ((Just x, debug $ "got echo for event: " ++ show x),+ ({- Common.incTime t lastTime -}+ echoTime, xs)))+ add time new = do+ MS.modify $ \(lastTime, old) ->+ (time,+ Common.mergeStable+ (EventList.fromAbsoluteEventList $+ EventListAbs.fromPairList $+ map (\(Common.Future dt a) -> (dt,a)) $+ List.sortBy (comparing Common.futureTime) new) $+ EventList.decreaseStart+ (Common.consTime "Causal.process.decreaseStart"+ (time-lastTime)) old)+ return (Nothing, send $ map (flip Common.incTime time . Common.futureTime) new)++ -- (Queue that keeps track of events to schedule+ -- , duration of the new alarm if applicable) + (eEchoEvent, _bQueue) =+ sequence (0, EventList.empty) $+ RB.union (fmap remove eEcho) (pure add <*> times <@> e)++ reactimate $ fmap snd eEchoEvent+ return $ RB.filterJust $ fmap fst eEchoEvent+++debug :: String -> IO ()+debug =+ const $ return ()+ -- putStrLn+++-- * utility functions++mapMaybe ::+ (RB.FRP f) => (a -> Maybe b) -> RBM.Event f a -> RBM.Event f b+mapMaybe f = RB.filterJust . fmap f++partitionMaybe ::+ (RB.FRP f) =>+ (a -> Maybe b) -> RBM.Event f a -> (RBM.Event f b, RBM.Event f a)+partitionMaybe f =+ (\x ->+ (mapMaybe fst x,+ mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .+ fmap (\a -> (f a, a))++traverse ::+ (RB.FRP f) =>+ s -> (a -> MS.State s b) -> RBM.Event f a ->+ (RBM.Event f b, RBM.Behavior f s)+traverse s f = sequence s . fmap f++sequence ::+ (RB.FRP f) =>+ s -> RBM.Event f (MS.State s a) ->+ (RBM.Event f a, RBM.Behavior f s)+sequence s =+ RB.mapAccum s . fmap MS.runState++constant ::+ (RB.FRP f) =>+ a -> RBM.Behavior f a+constant a = RB.stepper a RB.never+++-- * examples++{- |+register pressed keys+-}+pressed ::+ (RB.FRP f, KeySet.C set) =>+ set ->+ RBM.Event f Event.Data ->+ (RBM.Event f [Event.Data], RBM.Behavior f set)+pressed empty =+ traverse empty+ (\e ->+ case e of+ Event.NoteEv notePart note ->+ fmap (map (uncurry Event.NoteEv)) $+ KeySet.change notePart note+ body ->+ if Common.isAllNotesOff body+ then fmap (map (uncurry Event.NoteEv))+ KeySet.reset+ else return [e])++latch ::+ (RB.FRP f) =>+ RBM.Event f Event.Data ->+ (RBM.Event f Event.Data, RBM.Behavior f (Map.Map (Pitch, Channel) Velocity))+latch =+ mapPair (RB.filterJust, fmap KeySet.deconsLatch) .+ traverse KeySet.latch+ (\e -> do+ _ <- case e of+ Event.NoteEv notePart note ->+ fmap (fmap (uncurry Event.NoteEv)) $+ KeySet.latchChange notePart note+ _ -> return Nothing+ return $ Just e)++{- |+Demonstration of scheduleQueue,+but for real use prefer 'delay',+since this uses precisely timed delivery by ALSA.+-}+delaySchedule ::+ Common.Time ->+ RB.Behavior Common.TimeAbs ->+ RB.Event Event.Data -> Reactor (RB.Event Event.Data)+delaySchedule dt times =+ scheduleQueue times .+ fmap ((:[]) . Common.Future dt)++delay ::+ Common.Time ->+ RB.Event ev -> RB.Event (Common.Future ev)+delay dt =+ fmap (Common.Future dt)++delayAdd ::+ Common.Time ->+ RB.Event ev -> RB.Event (Common.Future ev)+delayAdd dt evs =+ RB.union (fmap Common.now evs) $ delay dt evs++{- |+Generate a beat according to the tempo control.+The input signal specifies the period between two beats.+The output events hold the times, where they occur.+-}+beat ::+ RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)+beat tempo = do+ (eEcho, send) <- reserveSchedule++ liftIO $ send [0]++ let next dt time =+ (time, send [Common.incTime dt time])++ eEchoEvent =+ RB.apply (fmap next tempo) eEcho++ reactimate $ fmap snd eEchoEvent+ return $ fmap fst eEchoEvent+++{- |+Similar to 'beat' but warrants a maximum reaction time to tempo changes.+This way you can alter slow tempos to faster one more quickly.+-}+{-+Instead of this we could use the reciprocal of Time, that is frequency,+and integrate that.+But integration of a piecewise constant function means a linear function.+This cannot be represented in FRP.+The approach we use here samples the tempo signal+and thus may miss some tempo changes.+-}+beatQuant ::+ Common.Time ->+ RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)+beatQuant maxDur tempo = do+ (eEcho, send) <- reserveSchedule++ liftIO $ send [0]++ let next dt time = do+ complete <- MS.gets (>=1)+ when complete $ MS.modify (subtract 1)+ portion <- MS.get+ let dur = limit (0,maxDur) (Common.scaleTimeCeiling (1-portion) dt)+ MS.modify (fromRational (Common.deconsTime dur / Common.deconsTime dt) +)+ return+ (toMaybe complete time,+ send [Common.incTime dur time]+ {- print (dur, time, dt, portion) -} )++ eEchoEvent =+ fst $ sequence 0 $ RB.apply (fmap next tempo) eEcho++ reactimate $ fmap snd eEchoEvent+ return $ RB.filterJust $ fmap fst eEchoEvent+++tempoCtrl ::+ (Check.C ev) =>+ Channel ->+ Controller ->+ Common.Time -> (Common.Time, Common.Time) ->+ RB.Event ev -> RB.Behavior Common.Time+tempoCtrl chan ctrl deflt (lower,upper) =+ RB.stepper deflt .+ RB.filterJust .+ fmap (fmap (Common.ctrlDur (lower, upper))+ . Check.controller chan ctrl)+++controllerRaw ::+ (Check.C ev) =>+ Channel ->+ Controller ->+ Int ->+ RB.Event ev -> RB.Behavior Int+controllerRaw chan ctrl deflt =+ RB.stepper deflt . RB.filterJust .+ fmap (Check.controller chan ctrl)++controllerExponential ::+ (Floating a, Check.C ev) =>+ Channel ->+ Controller ->+ a -> (a,a) ->+ RB.Event ev -> RB.Behavior a+controllerExponential chan ctrl deflt (lower,upper) =+ let k = log (upper/lower) / 127+ in RB.stepper deflt .+ RB.filterJust .+ fmap (fmap ((lower*) . exp . (k*) . fromIntegral)+ . Check.controller chan ctrl)++controllerLinear ::+ (Fractional a, Check.C ev) =>+ Channel ->+ Controller ->+ a -> (a,a) ->+ RB.Event ev -> RB.Behavior a+controllerLinear chan ctrl deflt (lower,upper) =+ let k = (upper-lower) / 127+ in RB.stepper deflt .+ RB.filterJust .+ fmap (fmap ((lower+) . (k*) . fromIntegral)+ . Check.controller chan ctrl)+++pattern ::+ (KeySet.C set) =>+ Pattern.Mono set i ->+ RB.Behavior Common.Time ->+ RB.Behavior set ->+ Reactor (RB.Event Common.EventDataBundle)+pattern pat tempo sets =+ fmap (patternAux pat tempo sets) $+ beat tempo++patternQuant ::+ (KeySet.C set) =>+ Common.Time ->+ Pattern.Mono set i ->+ RB.Behavior Common.Time ->+ RB.Behavior set ->+ Reactor (RB.Event Common.EventDataBundle)+patternQuant quant pat tempo sets =+ fmap (patternAux pat tempo sets) $+ beatQuant quant tempo++patternAux ::+ (KeySet.C set) =>+ Pattern.Mono set i ->+ RB.Behavior Common.Time ->+ RB.Behavior set ->+ RB.Event Common.TimeAbs ->+ RB.Event Common.EventDataBundle+patternAux (Pattern.Mono select ixs) tempo sets times =+ pure+ (\dur set i -> select i dur set)+ <*> tempo+ <*> sets+ <@> (RB.filterJust $ fst $+ RB.mapAccum ixs $+ fmap (\ _time is ->+ case is of+ [] -> (Nothing, is)+ i:rest -> (Just i, rest))+ times)++++cyclePrograms ::+ [Program] ->+ RB.Event Event.Data -> RB.Event (Maybe Event.Data)+cyclePrograms pgms =+ fst .+ traverse (cycle pgms)+ (Common.traverseProgramsSeek (length pgms))+++{- |+> cycleProgramsDefer t++After a note that triggers a program change,+we won't change the program in the next 't' seconds.+This is in order to allow chords being played+and in order to skip accidentally played notes.+-}+{-+In the future we might also add a time-out:+After a certain time, where no key is pressed,+the program would be reset to the initial program.+-}+cycleProgramsDefer ::+ Common.Time -> [Program] ->+ RB.Behavior Common.TimeAbs ->+ RB.Event Event.Data -> RB.Event (Maybe Event.Data)+cycleProgramsDefer defer pgms times =+ fst .+ traverse (cycle pgms, 0)+ (\(eventTime,e) ->+ case e of+ Event.CtrlEv Event.PgmChange ctrl ->+ AccState.lift AccTuple.first $+ Common.seekProgram (length pgms) (ctrl ^. MALSA.ctrlProgram)+ Event.NoteEv notePart note -> do+ blockTime <- MS.gets snd+ if eventTime < blockTime+ then return Nothing+ else+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> do+ AccState.set AccTuple.second $+ Common.incTime defer eventTime+ AccState.lift AccTuple.first $+ Common.nextProgram note+ _ -> return Nothing+ _ -> return Nothing) .+ RB.apply (fmap (,) times)+++newtype PitchChannel =+ PitchChannel ((Pitch, Channel), Velocity)+ deriving (Show)++instance Eq PitchChannel where+ (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =+ p0 == p1++instance Ord PitchChannel where+ compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =+ compare p0 p1++instance Guitar.Transpose PitchChannel where+ getPitch (PitchChannel ((p,_), _)) = p+ transpose d (PitchChannel ((p,c),v)) = do+ p' <- Common.increasePitch d p+ return $ PitchChannel ((p',c), v)++noteSequence ::+ Common.Time ->+ Event.NoteEv -> [Event.Note] ->+ Common.EventDataBundle+noteSequence stepTime onOff =+ zipWith Common.Future (iterate (stepTime+) 0) .+ map (Event.NoteEv onOff)++{- |+This process simulates playing chords on a guitar.+If you press some keys like C, E, G on the keyboard,+then this process figures out what tones would be played on a guitar.++Call it like @guitar stepTime chords triggers@.++@stepTime@ is the delay between to successive notes.+A good value is 0.03 (seconds).+The chords to be played are passed in by @chords@.+This should be the output of 'pressed'.+Further on the function needs events+that trigger playing the chord in @trigger@ argument.+The trigger consists of the trigger time+and the direction to be played+('True' = down from high to low pitches,+'False' = up from low to high pitches).+The trigger may be derived from a specific key that is pressed and released,+or two keys, one for each direction.+-}+guitar ::+ (KeySet.C set) =>+ Common.Time ->+ RB.Behavior set ->+ RB.Event Bool ->+ RB.Event Common.EventDataBundle+guitar stepTime pressd trigger =+ fst $+ traverse []+ (\(set, on) -> do+ played <- MS.get+ let toPlay =+ case KeySet.toList set of+ [] -> []+ list ->+ fmap (\(PitchChannel ((p,c),v)) ->+ MALSA.noteEvent c p v v 0) $+ Guitar.mapChordToString Guitar.stringPitches $+ fmap PitchChannel list+ MS.put toPlay+ return $+ if on+ then+ noteSequence stepTime Event.NoteOff+ (List.reverse played)+ +++ noteSequence stepTime Event.NoteOn toPlay+ else+ noteSequence stepTime Event.NoteOff played+ +++ noteSequence stepTime Event.NoteOn+ (List.reverse toPlay)) $+ pure (,) <*> pressd <@> trigger++++{- |+Audio perception trainer++Play sets of notes and+let the human player answer to them according to a given scheme.+Repeat playing the notes sets until the trainee answers correctly.+Then continue with other sequences, maybe more complicated ones.++possible tasks:++ - replay a sequence of pitches on the keyboard:+ single notes for training abolute pitches,+ intervals all with the same base notes,+ intervals with different base notes++ - transpose a set of pitches:+ tranpose to a certain base note,+ transpose by a certain interval++ - play a set of pitches in a different order:+ reversed order,+ in increasing pitch++ - replay a set of simultaneously pressed keys++The difficulty can be increased by not connecting+the keyboard directly with the sound generator.+This way, the trainee cannot verify,+how the pressed keys differ from the target keys.++Sometimes it seems that you are catched in an infinite loop.+This happens if there were too many keys pressed.+The trainer collects all key press events,+not only the ones that occur after the target set is played.+This way you can correct yourself immediately,+before the target is repeatedly played.+The downside is, that there may be key press events hanging around.+You can get rid of them by pressing a key again and again,+but slowly, until the target is played, again.+Then the queue of registered keys should be empty+and you can proceed training.+-}+{-+The Reactor monad is only needed for sending the initial notes.+-}+trainer ::+ Channel ->+ Common.Time -> Common.Time ->+ [([Pitch], [Pitch])] ->+ RB.Behavior Common.TimeAbs ->+ RB.Event Event.Data ->+ Reactor (RB.Event Common.EventDataBundle)+trainer chan pause duration sets0 times evs0 = do+ let makeSeq sets =+ case sets of+ (target, _) : _ ->+ (concat $+ zipWith+ (\t p ->+ Common.eventsFromKey t duration+ ((p,chan), normalVelocity))+ (iterate (duration+) pause) target,+ pause + duration * fromIntegral (length target))+ [] -> ([], 0)++ let (initial, initIgnoreUntil) = makeSeq sets0+ getHandle >>= \h -> liftIO (outputEvents h 0 initial)++ return $ fst $+ flip (traverse (sets0, [], Common.incTime initIgnoreUntil 0))+ (fmap (,) times <@> evs0) $ \(time,ev) ->+ case ev of+ Event.NoteEv notePart note ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> do+ ignoreUntil <- AccState.get AccTuple.third3+ if time <= ignoreUntil+ then return []+ else do+ pressd <- AccState.get AccTuple.second3+ let newPressd = (note ^. MALSA.notePitch) : pressd+ AccState.set AccTuple.second3 newPressd+ sets <- AccState.get AccTuple.first3+ case sets of+ (_, target) : rest ->+ if Match.lessOrEqualLength target newPressd+ then do+ AccState.set AccTuple.second3 []+ when (newPressd == List.reverse target) $+ AccState.set AccTuple.first3 rest+ (notes, newIgnoreUntil) <-+ fmap makeSeq $+ AccState.get AccTuple.first3+ AccState.set AccTuple.third3 $+ Common.incTime newIgnoreUntil time+ return notes+ else return []+ _ -> return []+ _ -> return []+ _ -> return []+++sweep ::+ Common.Time ->+ (Double -> Double) ->+ RB.Behavior Double ->+ Reactor (RB.Event Common.TimeAbs, RB.Behavior Double)+sweep dur wave speed = do+ bt <- beat $ constant dur+ let durD = realToFrac $ Common.deconsTime dur+ return+ (bt,+ fmap wave $ RB.accumB 0 $+ fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)++makeControllerLinear ::+ Channel -> Controller ->+ RB.Behavior Int ->+ RB.Behavior Int ->+ RB.Event Common.TimeAbs -> RB.Behavior Double ->+ RB.Event Event.Data+makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =+ pure+ (\y depth center _time ->+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent chan cc $+ round $ limit (0,127) $+ fromIntegral center + fromIntegral depth * y)+ <*> ctrl+ <*> depthCtrl+ <*> centerCtrl+ <@> bt
+ src/Reactive/Banana/ALSA/Training.hs view
@@ -0,0 +1,110 @@+module Reactive.Banana.ALSA.Training (+ all,+ intervals,+ twoNotes,+ threeNotes,+ reverseThreeNotes,+ sortThreeNotes,+ transposeTwoNotes,+ ) where++import Reactive.Banana.ALSA.Common (pitch, increasePitch, subtractPitch, )+import Sound.MIDI.Message.Channel.Voice (Pitch, )++import System.Random (RandomGen, Random, randomR, )+import Control.Monad.Trans.State (State, state, evalState, )+import Control.Monad (liftM2, )+import Data.Maybe (mapMaybe, )+import qualified Data.List as List+import Prelude hiding (all, )+++{- | chose a random item from a list -}+-- from htam+randomItem :: (RandomGen g) => [a] -> State g a+randomItem x = fmap (x!!) (randomRState (length x - 1))++randomRState :: (RandomGen g, Random a, Num a) => a -> State g a+randomRState upper = state (randomR (0, upper))+++baseKey :: Pitch+baseKey = pitch 60++notes :: [Pitch]+notes =+ mapMaybe (flip increasePitch baseKey)+ [0, 12, 7, 5, 4, 2, 9, 11, 3, 10, 1, 6, 8]+++all :: RandomGen g => g -> [([Pitch], [Pitch])]+all g =+ intervals g ++ twoNotes g ++ threeNotes g +++ reverseThreeNotes g ++ sortThreeNotes g +++ transposeTwoNotes g++-- | intervals within an octave, all starting with a C+intervals :: RandomGen g => g -> [([Pitch], [Pitch])]+intervals g =+ flip evalState g $+ mapM randomItem $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ map (\p -> let ps = [baseKey, p] in (ps, ps)) $+ notes++-- | choose two arbitrary notes from an increasing set of notes+twoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+twoNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso,pso)) $+ mapM randomItem [ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++-- | choose three arbitrary notes from an increasing set of notes+threeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+threeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso,pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++reverseThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+reverseThreeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso, reverse pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++sortThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+sortThreeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso, List.sort pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++-- | transpose an interval to begin with C+transposeTwoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+transposeTwoNotes g =+ flip evalState g $+ mapM (\ps ->+ liftM2+ (\p0 p1 ->+ let pso = [p0,p1]+ in (pso, mapMaybe (increasePitch (subtractPitch p0 baseKey)) pso))+ (randomItem ps) (randomItem ps)) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes
+ src/Reactive/Banana/ALSA/Trie.hs view
@@ -0,0 +1,44 @@+{- |+This module is only needed for DeBruijn sequence generation.+-}+module Reactive.Banana.ALSA.Trie where++import qualified Data.List as List+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (mapMaybe, )++import Prelude hiding (null, lookup)+++data Trie a b = Leaf b | Branch [(a, Trie a b)]+ deriving (Show)++full :: b -> [a] -> Int -> Trie a b+full b _ 0 = Leaf b+full b as n =+ Branch $+ map (\a -> (a, full b as (n-1))) as++null :: Trie a [b] -> Bool+null (Branch []) = True+null (Leaf []) = True+null _ = False++delete :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]+delete b [] (Leaf bs) = Leaf (List.delete b bs)+delete b (a:as) (Branch subTries) =+ Branch $ mapMaybe+ (\(key,trie) ->+ fmap ((,) key) $+ if key==a+ then let delTrie = delete b as trie+ in toMaybe (not (null delTrie)) delTrie+ else Just trie)+ subTries+delete _ _ _ = error "Trie.delete: key and trie depth mismatch"++lookup :: (Eq a) => [a] -> Trie a b -> Maybe b+lookup [] (Leaf b) = Just b+lookup (a:as) (Branch subTries) =+ List.lookup a subTries >>= lookup as+lookup _ _ = error "Trie.lookup: key and trie depth mismatch"