packages feed

reactive-midyim (empty) → 0.2

raw patch · 18 files changed

+2556/−0 lines, 18 filesdep +basedep +containersdep +data-accessorsetup-changed

Dependencies added: base, containers, data-accessor, data-accessor-transformers, event-list, midi, non-negative, random, reactive-banana, transformers, utility-ht

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2013, 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-midyim.cabal view
@@ -0,0 +1,82 @@+Name:             reactive-midyim+Version:          0.2+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/Reactive-balsa+Category:         Sound, Music+Build-Type:       Simple+Synopsis:         Process MIDI events via 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==7.4.1+Cabal-Version:    >=1.6+Build-Type:       Simple+Source-Repository head+  type:     darcs+  location: http://hub.darcs.net/thielema/reactive-midyim/++Source-Repository this+  type:     darcs+  location: http://hub.darcs.net/thielema/reactive-midyim/+  tag:      0.2++Library+  Build-Depends:+    reactive-banana >=0.7 && <0.8,+    midi >=0.2 && <0.3,+    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.6,+    transformers >=0.2 && <0.6,+    random >=1 && <2,+    base >=4 && <5++  GHC-Options:      -Wall+  Hs-Source-Dirs:   src+  Exposed-Modules:+    Reactive.Banana.MIDI.KeySet+    Reactive.Banana.MIDI.Pattern+    Reactive.Banana.MIDI.Guitar+    Reactive.Banana.MIDI.Training+    Reactive.Banana.MIDI.Common+    Reactive.Banana.MIDI.Utility+    Reactive.Banana.MIDI.Process+    Reactive.Banana.MIDI.Pitch+    Reactive.Banana.MIDI.Note+    Reactive.Banana.MIDI.Time+    Reactive.Banana.MIDI.IndexedMonad+    Reactive.Banana.MIDI.Program+    Reactive.Banana.MIDI.Controller+  Other-Modules:+    Reactive.Banana.MIDI.DeBruijn+    Reactive.Banana.MIDI.Trie
+ src/Reactive/Banana/MIDI/Common.hs view
@@ -0,0 +1,117 @@+module Reactive.Banana.MIDI.Common where++import qualified Reactive.Banana.MIDI.Time as Time++import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++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 qualified Numeric.NonNegative.Class as NonNeg++import Data.Monoid (mempty, )++++-- * 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 :: Velocity+normalVelocity = VoiceMsg.normalVelocity++++-- * Fractions++-- | properFraction is useless for negative numbers+splitFraction :: (RealFrac a) => a -> (Int, a)+splitFraction x =+   case floor x of+      n -> (n, x - fromIntegral n)+++fraction :: RealFrac a => a -> a+fraction x =+   x - fromIntegral (floor x :: Integer)+++-- * Notes++{-+The Ord instance is intended for use in a Map,+but it shall not express a notion of magnitude.+-}+data PitchChannel =+     PitchChannel Pitch Channel+   deriving (Eq, Ord, Show)++data PitchChannelVelocity =+     PitchChannelVelocity PitchChannel Velocity+   deriving (Eq, Show)+++class VelocityField x where+   getVelocity :: x -> Velocity++instance VelocityField Velocity where+   getVelocity = id++++-- * time stamped objects++{- |+The times are relative to the start time of the bundle+and do not need to be ordered.+-}+data Future m a = Future {futureTime :: Time.T m Time.Relative Time.Ticks, futureData :: a}+type Bundle m a = [Future m a]++singletonBundle :: a -> Bundle m a+singletonBundle ev = [now ev]++immediateBundle :: [a] -> Bundle m a+immediateBundle = map now++now :: a -> Future m a+now = Future mempty++instance Functor (Future m) where+   fmap f (Future dt a) = Future dt $ f a++++-- * 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/MIDI/Controller.hs view
@@ -0,0 +1,65 @@+module Reactive.Banana.MIDI.Controller where++import qualified Reactive.Banana.MIDI.Time as Time++import qualified Sound.MIDI.Message.Class.Query as Query+import qualified Sound.MIDI.Message.Class.Construct as Construct+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Controller, )++import Data.Maybe.HT (toMaybe, )+import Data.Monoid (mappend, )+++tempoDefault :: (Channel, Controller)+tempoDefault =+   (ChannelMsg.toChannel 0, VoiceMsg.toController 16)+++type RelativeTickTime m = Time.T m Time.Relative Time.Ticks++duration, durationLinear, durationExponential ::+   (RelativeTickTime m, RelativeTickTime m) ->+   Int -> RelativeTickTime m+duration = durationExponential++durationLinear (minDur, maxDur) val =+   let k = fromIntegral val / 127+   in  Time.scale (1-k) minDur+       `mappend`+       Time.scale k maxDur+--   minDur + Time.scale (fromIntegral val / 127) (maxDur-minDur)++durationExponential (minDur, maxDur) val =+   Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur+++{-+range ::+   (RealFrac b) =>+   (b,b) -> (a -> b) -> (a -> Int)+range (l,u) f x =+   round $+   limit (0,127) $+   127*(f x - l)/(u-l)+-}+++{- |+Map NoteOn events to a controller value.+This way you may play notes via the resonance frequency of a filter.+-}+fromNote ::+   (Query.C msg, Construct.C msg) =>+   (Int -> Int) -> Controller -> msg -> Maybe msg+fromNote f ctrl e =+   maybe+      (Just e)+      (\(c, (_v, p, on)) ->+         toMaybe on $+         curry (Construct.anyController c) ctrl $+         f $ VoiceMsg.fromPitch p)+      (Query.noteExplicitOff e)
+ src/Reactive/Banana/MIDI/DeBruijn.hs view
@@ -0,0 +1,138 @@+module Reactive.Banana.MIDI.DeBruijn where++import qualified Reactive.Banana.MIDI.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' n k@ is a sequence with length n^k+where @cycle ('lexLeast' n k)@ contains all n-ary numbers with k digits as infixes.+The function computes the lexicographically smallest of such sequences.+-}+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/MIDI/Guitar.hs view
@@ -0,0 +1,30 @@+-- cf. Haskore/Guitar+module Reactive.Banana.MIDI.Guitar where++import qualified Reactive.Banana.MIDI.Pitch as Pitch+import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, )++import qualified Data.List.Key as Key+import Data.Maybe (mapMaybe, )+++mapChordToString ::+   (Pitch.C pitch) =>+   [Pitch] -> [pitch] -> [pitch]+mapChordToString strings chord =+   mapMaybe (choosePitchForString chord) strings++choosePitchForString ::+   (Pitch.C pitch) =>+   [pitch] -> Pitch -> Maybe pitch+choosePitchForString chord string =+   let roundDown x d = x - mod x d+       minAbove x =+          Pitch.increase+             (- roundDown (Pitch.subtract string (Pitch.extract x)) 12) x+   in  Key.maximum (fmap Pitch.extract) $ 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/MIDI/IndexedMonad.hs view
@@ -0,0 +1,26 @@+{-+This module could as well live in a separate package.+-}+module Reactive.Banana.MIDI.IndexedMonad where++import Control.Applicative (Applicative, pure, (<*>), )+import Control.Monad (liftM, ap, )+++class C m where+   point :: a -> m s a+   bind :: m s a -> (a -> m s b) -> m s b+++newtype Wrap m s a = Wrap {unwrap :: m s a}++instance C m => Functor (Wrap m s) where+   fmap = liftM++instance C m => Applicative (Wrap m s) where+   pure = return+   (<*>) = ap++instance C m => Monad (Wrap m s) where+   return = Wrap . point+   Wrap x >>= k  =  Wrap $ bind x (unwrap . k)
+ src/Reactive/Banana/MIDI/KeySet.hs view
@@ -0,0 +1,260 @@+module Reactive.Banana.MIDI.KeySet where++import qualified Reactive.Banana.MIDI.Note as Note++import qualified Data.Traversable as Trav++import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Basic as Acc++import qualified Control.Monad.Trans.State as MS++import qualified Data.Map as Map+import qualified Data.Set as Set++import Data.Maybe.HT (toMaybe, )+import Data.Maybe (maybeToList, listToMaybe, )+++{-+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 key value) [Note.Boundary key value]+   {- |+   It must hold @reset == resetSome (const True)@.+   -}+   resetSome :: Ord key => (key -> Bool) -> MS.State (set key value) [Note.Boundary key value]+   size :: set key value -> Int+   toList :: set key value -> [(key, value)]+   index :: Ord key => Int -> set key value -> Maybe (key, value)+   change :: Ord key => Note.Boundary key value -> MS.State (set key value) [Note.Boundary key value]++changeExt ::+   (Ord key, C set) =>+   Note.BoundaryExt key value ->+   MS.State (set key value) [Note.Boundary key value]+changeExt e =+   case e of+      Note.BoundaryExt bnd -> change bnd+      Note.AllOff p -> resetSome p++class Map set where+   accessMap :: Acc.T (set key value) (Map.Map key value)+++newtype Pressed key value = Pressed {deconsPressed :: Map.Map key value}+   deriving (Show)++pressed :: Pressed key value+pressed = Pressed Map.empty++instance Map Pressed where+   accessMap = Acc.fromWrapper Pressed deconsPressed++instance C Pressed where+   reset = releasePlayedKeys+   resetSome = releaseSomeKeys+   size = sizeGen+   toList = toListGen+   index = indexGen+   change bnd@(Note.Boundary key vel on) = do+      AccState.modify accessMap $+         if on+           then Map.insert key vel+           else Map.delete key+      return [bnd]++++newtype Latch key value = Latch {deconsLatch :: Map.Map key value}+   deriving (Show)++latch :: Latch key value+latch = Latch Map.empty++instance Map Latch where+   accessMap = Acc.fromWrapper Latch deconsLatch++latchChange ::+   Ord key =>+   Note.Boundary key value ->+   MS.State (Latch key value) (Maybe (Note.Boundary key value))+latchChange (Note.Boundary key vel on) =+   Trav.sequence $ toMaybe on $ do+      isPressed <- MS.gets (Map.member key . deconsLatch)+      if isPressed+        then+           AccState.modify accessMap (Map.delete key) >>+           return (Note.Boundary key vel False)+        else+           AccState.modify accessMap (Map.insert key vel) >>+           return (Note.Boundary key vel True)++instance C Latch where+   reset = releasePlayedKeys+   resetSome = releaseSomeKeys+   size = sizeGen+   toList = toListGen+   index = indexGen+   change = fmap maybeToList . latchChange++++data GroupLatch key value =+   GroupLatch {+      groupLatchPressed_ {- input -} :: Set.Set key,+      groupLatchPlayed_ {- output -} :: Map.Map key value+   } deriving (Show)++groupLatch :: GroupLatch key value+groupLatch = GroupLatch Set.empty Map.empty++groupLatchPressed :: Acc.T (GroupLatch key value) (Set.Set key)+groupLatchPressed =+   Acc.fromSetGet+      (\mp grp -> grp{groupLatchPressed_ = mp})+      groupLatchPressed_++groupLatchPlayed :: Acc.T (GroupLatch key value) (Map.Map key value)+groupLatchPlayed =+   Acc.fromSetGet+      (\mp grp -> grp{groupLatchPlayed_ = mp})+      groupLatchPlayed_++instance Map GroupLatch where+   accessMap = 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 = releasePlayedKeys+   resetSome = releaseSomeKeys+   size = sizeGen+   toList = toListGen+   index = indexGen+   change (Note.Boundary key vel on) =+      if on+        then do+           pressd <- AccState.get groupLatchPressed+           noteOffs <-+              if Set.null pressd+                then 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 [Note.Boundary key vel True]+           return $+              noteOffs ++ noteOn+        else+           AccState.modify groupLatchPressed (Set.delete key) >>+           return []++++data SerialLatch key value =+   SerialLatch {+      serialLatchSize_ :: Int,+      serialLatchCursor_ :: Int,+      serialLatchPlayed_ :: Map.Map Int (key, value)+   } deriving (Show)++serialLatch :: Int -> SerialLatch key value+serialLatch num = SerialLatch num 0 Map.empty++serialLatchCursor :: Acc.T (SerialLatch key value) Int+serialLatchCursor =+   Acc.fromSetGet+      (\mp grp -> grp{serialLatchCursor_ = mp})+      serialLatchCursor_++serialLatchPlayed :: Acc.T (SerialLatch key value) (Map.Map Int (key, value))+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)+   resetSome p =+      fmap (map (uncurry releaseKey) . Map.elems) $+      AccState.lift serialLatchPlayed $+      MS.state $ Map.partition (p . fst)+   size = serialLatchSize_+   toList = Map.elems . serialLatchPlayed_+   index k = Map.lookup k . serialLatchPlayed_+   change bnd@(Note.Boundary key vel on) =+      if on+        then 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)+                     ++ [bnd]+        else return []++sizeGen :: (Map set) => set key value -> Int+sizeGen = Map.size . Acc.get accessMap++toListGen :: (Map set) => set key value -> [(key, value)]+toListGen = Map.toAscList . Acc.get accessMap++indexGen ::+   (Ord key, Map set) =>+   Int -> set key value -> Maybe (key, value)+indexGen k =+   listToMaybe . drop k . Map.toAscList . Acc.get accessMap++releasePlayedKeys ::+   (Map set) =>+   MS.State+      (set key value)+      [Note.Boundary key value]+releasePlayedKeys =+   fmap (map (uncurry releaseKey) . Map.toList) $+   AccState.getAndModify accessMap $ const Map.empty++releaseSomeKeys ::+   (Ord key, Map set) =>+   (key -> Bool) ->+   MS.State+      (set key value)+      [Note.Boundary key value]+releaseSomeKeys p =+   fmap (map (uncurry releaseKey) . Map.toList) $+   AccState.lift accessMap $ MS.state $+   Map.partitionWithKey (const . p)++releaseKey ::+   key -> value -> Note.Boundary key value+releaseKey key vel =+   Note.Boundary key vel False
+ src/Reactive/Banana/MIDI/Note.hs view
@@ -0,0 +1,141 @@+module Reactive.Banana.MIDI.Note where++import qualified Reactive.Banana.MIDI.Pitch as Pitch+import qualified Reactive.Banana.MIDI.Time as Time+import qualified Reactive.Banana.MIDI.Common as Common+import Reactive.Banana.MIDI.Common (PitchChannel(PitchChannel), )++import qualified Sound.MIDI.Message.Class.Query as Query+import qualified Sound.MIDI.Message.Class.Construct as Construct+import qualified Sound.MIDI.Message.Channel.Mode as Mode+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )++import Control.Monad (mplus, )+import Data.Monoid (mappend, )++++data Boundary key value =+     Boundary key value Bool+   deriving (Eq, Show)++data BoundaryExt key value =+     BoundaryExt (Boundary key value)+   | AllOff (key -> Bool)+   {- ^+   The predicate shall return True,+   if a certain key shall be released by the AllOff statement.+   E.g. the predicate might check for the appropriate channel.+   -}+++maybeBnd ::+   Query.C msg =>+   msg -> Maybe (Boundary PitchChannel Velocity)+maybeBnd =+   fmap (\(c, (v, p, on)) -> Boundary (PitchChannel p c) v on) . Query.note++maybeBndExt ::+   Query.C msg =>+   msg -> Maybe (BoundaryExt PitchChannel Velocity)+maybeBndExt ev =+   mplus+      (fmap BoundaryExt $ maybeBnd ev)+      (let allOff chan = Just $ AllOff $ \(PitchChannel _p c) -> chan == c+       in  case Query.mode ev of+               Just (chan, Mode.AllNotesOff) -> allOff chan+               Just (chan, Mode.AllSoundOff) -> allOff chan+               _ -> Nothing)+++class Pitch.C x => Make x where+   make :: Construct.C msg => x -> Velocity -> Bool -> msg++instance Make Pitch where+   make p =+      make (PitchChannel p minBound)++instance Make PitchChannel where+   make (PitchChannel p c) vel on =+      Construct.note c (vel, p, on)++++fromBnd ::+   (Make key, Common.VelocityField value, Construct.C msg) =>+   Boundary key value -> msg+fromBnd (Boundary pc vel on) =+   make pc (Common.getVelocity vel) on+++bundle ::+   (Construct.C msg) =>+   Time.T m Time.Relative Time.Ticks ->+   Time.T m Time.Relative Time.Ticks ->+   (PitchChannel, Velocity) ->+   Common.Bundle m msg+bundle start dur (pc, vel) =+   Common.Future start (make pc vel True) :+   Common.Future (mappend start dur) (make pc vel False) :+   []++++++lift ::+   (Query.C msg, Construct.C msg) =>+   (Boundary PitchChannel Velocity -> Boundary PitchChannel Velocity) ->+   (msg -> Maybe msg)+lift f msg =+   fmap (fromBnd . f) $ maybeBnd msg++liftMaybe ::+   (Query.C msg, Construct.C msg) =>+   (Boundary PitchChannel Velocity -> Maybe (Boundary PitchChannel Velocity)) ->+   (msg -> Maybe msg)+liftMaybe f msg =+   fmap fromBnd . f =<< maybeBnd msg++{- |+Pitch.C 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 ->+   Boundary PitchChannel v ->+   Maybe (Boundary PitchChannel v)+transpose d (Boundary (PitchChannel p0 c) v on) =+   fmap+      (\p1 -> Boundary (PitchChannel p1 c) v on)+      (Pitch.increase d p0)++{- |+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 ::+   Boundary PitchChannel v ->+   Maybe (Boundary PitchChannel v)+reverse (Boundary (PitchChannel p0 c) v on) =+   fmap+      (\p1 -> Boundary (PitchChannel p1 c) v on)+      (Pitch.maybeFromInt $ (60+64 -) $ VoiceMsg.fromPitch p0)++reduceVelocity ::+   Velocity ->+   Boundary pc Velocity ->+   Boundary pc Velocity+reduceVelocity decay (Boundary pc v on) =+   Boundary pc+      (case VoiceMsg.fromVelocity v of+         0 -> v+         vel ->+            VoiceMsg.toVelocity $+            vel - min (VoiceMsg.fromVelocity decay) (vel-1))+      on
+ src/Reactive/Banana/MIDI/Pattern.hs view
@@ -0,0 +1,414 @@+module Reactive.Banana.MIDI.Pattern where++import qualified Reactive.Banana.MIDI.Note as Note+import qualified Reactive.Banana.MIDI.KeySet as KeySet+import qualified Reactive.Banana.MIDI.DeBruijn as DeBruijn+import qualified Reactive.Banana.MIDI.Pitch as Pitch++import Reactive.Banana.MIDI.Common (splitFraction, )++import qualified Reactive.Banana.MIDI.Utility as RBU+import qualified Reactive.Banana.Combinators as RB+import Reactive.Banana.Combinators ((<@>), )++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel.Voice (Velocity, )++import qualified Data.EventList.Absolute.TimeBody as AbsEventList+import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import Data.EventList.Relative.MixedBody ((/.), (./), )+import qualified Numeric.NonNegative.Wrapper as NonNegW++import qualified Data.List.HT as ListHT+import qualified Data.List as List++import qualified System.Random as Rnd++import qualified Control.Monad.Trans.State as MS++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import Control.Monad (guard, )+import Control.Applicative (Applicative, pure, (<*>), )+import Data.Maybe (mapMaybe, maybeToList, )+import Data.Bool.HT (if', )+import Data.Ord.HT (comparing, )++import Prelude hiding (init, filter, reverse, )++++-- * reactive patterns++type T t time set key value =+   RB.Behavior t (set key value) ->+   RB.Event t time ->+   RB.Event t [Note.Boundary key value]++mono ::+   (KeySet.C set) =>+   Selector set key Velocity i ->+   RB.Behavior t (set key Velocity) ->+   RB.Event t i ->+   RB.Event t [Note.Boundary key Velocity]+mono select pressed pattern =+   fst $ RBU.sequence [] $+   pure+      (\set i -> do+         off <- MS.get+         let mnote = select i set+             on =+                fmap+                   (\(key, vel) -> Note.Boundary key vel True)+                   mnote+         MS.put $ fmap+            (\(key, _vel) -> Note.Boundary key VoiceMsg.normalVelocity False)+            mnote+         return $ off ++ on)+      <*> pressed+      <@> pattern+++poly ::+   (KeySet.C set) =>+   Selector set key Velocity i ->+   RB.Behavior t (set key Velocity) ->+   RB.Event t [IndexNote i] ->+   RB.Event t [Note.Boundary key Velocity]+poly select pressed pattern =+   fst $ RBU.sequence EventList.empty $+   pure+      (\set is -> do+         off <- MS.get+         let (nowOff, laterOff) = EventListTM.splitAtTime 1 off+             sel = concatMap (Trav.traverse (flip select set)) is+             on =+                fmap+                   (\(IndexNote _ (key, vel)) ->+                      Note.Boundary key vel True)+                   sel+         MS.put $+            EventList.mergeBy (\ _ _ -> False) laterOff $+            EventList.fromAbsoluteEventList $+            AbsEventList.fromPairList $+            List.sortBy (comparing fst) $+            map+               (\(IndexNote dur (key, _vel)) ->+                  (dur, Note.Boundary key VoiceMsg.normalVelocity False))+            sel+         return $ Fold.toList nowOff ++ on)+      <*> pressed+      <@> pattern++++-- * selectors++type Selector set key value i =+        i -> set key value -> [(key, value)]+++data IndexNote i = IndexNote NonNegW.Int i+   deriving (Show, Eq, Ord)++instance Functor IndexNote where+   fmap f (IndexNote d i) = IndexNote d $ f i++instance Fold.Foldable IndexNote where+   foldMap = Trav.foldMapDefault++instance Trav.Traversable IndexNote where+   sequenceA (IndexNote d i) = fmap (IndexNote d) i+++item :: i -> Int -> IndexNote i+item i n = IndexNote (NonNegW.fromNumberMsg "Pattern.item" n) i++data+   Poly set key value i =+      Poly (Selector set key value 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, Ord pitch, Pitch.C pitch) =>+   Selector set pitch value Int+selectFromOctaveChord d chord =+   maybeToList $ do+      let size = KeySet.size chord+      guard (size>0)+      let (q,r) = divMod d size+      (pc, vel) <- KeySet.index r chord+      pcTrans <- Pitch.increase (12*q) pc+      return (pcTrans, vel)++selectFromChord ::+   (KeySet.C set, Ord key) =>+   Selector set key value Int+selectFromChord n chord =+   maybeToList $ KeySet.index n chord++selectFromChordRatio ::+   (KeySet.C set, Ord key) =>+   Selector set key value Double+selectFromChordRatio d chord =+   selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord+++selectInversion ::+   (KeySet.C set, Pitch.C pitch) =>+   Selector set pitch value Double+selectInversion d chord =+   let makeNote octave (pc, vel) =+          fmap+             (\pcTrans -> (pcTrans, vel))+             (Pitch.increase (octave*12) pc)+       (oct,p) = splitFraction d+       pivot = floor (p * fromIntegral (KeySet.size chord))+       (low,high) = splitAt pivot $ KeySet.toList chord+   in  mapMaybe (makeNote oct) high +++       mapMaybe (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]+++cycleUpIndex, cycleDownIndex, pingPongIndex ::+   RB.Behavior t Int ->+   RB.Event t time ->+   RB.Event t Int+cycleUpIndex numbers times =+   fst $ RB.mapAccum 0 $+   pure+      (\number _time i -> (i, mod (succ i) (max 1 number)))+      <*> numbers+      <@> times++cycleDownIndex numbers times =+   RB.accumE 0 $+   pure+      (\number _time i -> mod (pred i) (max 1 number))+      <*> numbers+      <@> times++pingPongIndex numbers times =+   fst $ RB.mapAccum (0,1) $+   pure+      (\number _time (i,d0) ->+         (i, let j = i+d0+                 d1 =+                    if' (j>=number) (-1) $+                    if' (j<0) 1 d0+             in  (i+d1, d1)))+      <*> numbers+      <@> times++crossSumIndex ::+   RB.Behavior t Int ->+   RB.Event t time ->+   RB.Event t Int+crossSumIndex numbers times =+   pure+      (\number i ->+         let m = fromIntegral number+         in  if m <= 1+               then 0+               else fromInteger $ flip mod m $ sum $ decomposePositional m i)+      <*> numbers+      <@> fromList [0..] times+++crossSumStaticIndex ::+   Int ->+   RB.Event t time ->+   RB.Event t Int+crossSumStaticIndex number =+   fromList (flipSeq number)++fromList :: [a] -> RB.Event t time -> RB.Event t a+fromList xs times =+   RB.filterJust $ fst $ RB.mapAccum xs $+   fmap+      (\_time xs0 ->+         case xs0 of+            [] -> (Nothing, [])+            x:xs1 -> (Just x, xs1))+      times+++cycleUp, cycleDown, pingPong, crossSum ::+   (KeySet.C set, Ord key) =>+   RB.Behavior t Int -> T t time set key Velocity+cycleUp   numbers sets times =+   mono selectFromChord sets (cycleUpIndex numbers times)+cycleDown numbers sets times =+   mono selectFromChord sets (cycleDownIndex numbers times)+pingPong  numbers sets times =+   mono selectFromChord sets (pingPongIndex numbers times)+crossSum  numbers sets times =+   mono selectFromChord sets (crossSumIndex numbers times)++bruijn ::+   (KeySet.C set, Ord key) =>+   Int -> Int -> T t time set key Velocity+bruijn n k sets times =+   mono selectFromChord sets $+   fromList (cycle $ DeBruijn.lexLeast n k) times+++binaryStaccato, binaryLegato, binaryAccident ::+   (KeySet.C set, Ord key) => T t time set key Velocity+{-+binary number Pattern.T:+   0+   1+   0 1+   2+   0 2+   1 2+   0 1 2+   3+-}+binaryStaccato sets times =+   poly+      selectFromChord+      sets+      (flip fromList times $+       map+          (map (IndexNote 1 . fst) .+           List.filter ((/=0) . snd) .+           zip [0..] .+           decomposePositional 2)+          [0..])++binaryLegato sets times =+   poly+      selectFromChord+      sets+      (flip fromList times $+       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 sets times =+   poly+      selectFromChord+      sets+      (flip fromList times $+       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, Ord pitch, Pitch.C pitch) =>+   RB.Behavior t Int -> T t time set pitch Velocity+cycleUpOctave numbers sets times =+   mono selectFromOctaveChord sets (cycleUpIndex numbers times)+++random ::+   (KeySet.C set, Ord key) =>+   T t time set key Velocity+random sets times =+   mono selectFromChordRatio sets $+   fst $ RB.mapAccum (Rnd.mkStdGen 42) $+   fmap (const $ Rnd.randomR (0,1)) times++randomInversions ::+   (KeySet.C set, Pitch.C pitch) =>+   T t time set pitch Velocity+randomInversions =+   inversions $+   map sum $+   ListHT.sliceVertical 3 $+   Rnd.randomRs (-1,1) $+   Rnd.mkStdGen 42++cycleUpInversions ::+   (KeySet.C set, Pitch.C pitch) =>+   Int -> T t time set pitch Velocity+cycleUpInversions n =+   inversions $ cycle $ take n $+   map (\i -> fromInteger i / fromIntegral n) [0..]++inversions ::+   (KeySet.C set, Pitch.C pitch) =>+   [Double] -> T t time set pitch Velocity+inversions rs sets times =+   mono selectInversion sets (fromList rs times)++++-- * 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/MIDI/Pitch.hs view
@@ -0,0 +1,62 @@+module Reactive.Banana.MIDI.Pitch where++import Reactive.Banana.MIDI.Common+          (PitchChannel(PitchChannel),+           PitchChannelVelocity(PitchChannelVelocity), )++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel.Voice (Pitch, fromPitch, )++import Data.Bool.HT (if', )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (fromMaybe, )++import Prelude hiding (subtract, )+++class C pitch where+   extract :: pitch -> Pitch+   increase :: Int -> pitch -> Maybe pitch++instance C Pitch where+   extract = id+   increase d p =+      maybeFromInt $ d + VoiceMsg.fromPitch p+++instance C PitchChannel where+   extract (PitchChannel p _) = p+   increase d (PitchChannel p c) = do+      p' <- increase d p+      return $ PitchChannel p' c++instance C PitchChannelVelocity where+   extract (PitchChannelVelocity pc _) = extract pc+   increase d (PitchChannelVelocity pc v) = do+      pc' <- increase d pc+      return $ PitchChannelVelocity pc' v+++maybeFromInt :: Int -> Maybe Pitch+maybeFromInt p =+   toMaybe+      (VoiceMsg.fromPitch minBound <= p  &&+       p <= VoiceMsg.fromPitch maxBound)+      (VoiceMsg.toPitch p)++subtract :: Pitch -> Pitch -> Int+subtract p0 p1 =+   VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0++++toClosestOctave :: C pitch => Int -> pitch -> pitch+toClosestOctave target sourceClass =+   let t = target+       s = fromPitch $ extract sourceClass+       x = mod (s - t + 6) 12 + t - 6+       y =+          if' (x<0) (x+12) $+          if' (x>127) (x-12) x+   in  fromMaybe (error "toClosestOctave: pitch should always be in MIDI note range") $+       increase (y-s) sourceClass
+ src/Reactive/Banana/MIDI/Process.hs view
@@ -0,0 +1,696 @@+module Reactive.Banana.MIDI.Process (+   RelativeTicks,+   AbsoluteTicks,+   RelativeSeconds,+   Moment(liftMoment),+   Reactor(reserveSchedule),+   scheduleQueue,+   initialEvent,+   beat,+   beatQuant,+   beatVar,+   delaySchedule,+   delay,+   delayAdd,+   pressed,+   latch,+   controllerRaw,+   controllerExponential,+   controllerLinear,+   tempoCtrl,+   snapSelect,+   uniqueChanges,+   sweep,+   makeControllerLinear,+   cyclePrograms,+   cycleProgramsDefer,+   noteSequence,+   guitar,+   trainer,+   ) where++import qualified Reactive.Banana.MIDI.Guitar as Guitar+import qualified Reactive.Banana.MIDI.Program as Program+import qualified Reactive.Banana.MIDI.Controller as Ctrl+import qualified Reactive.Banana.MIDI.Note as Note+import qualified Reactive.Banana.MIDI.Time as Time+import qualified Reactive.Banana.MIDI.KeySet as KeySet+import qualified Reactive.Banana.MIDI.Pitch as Pitch+import qualified Reactive.Banana.MIDI.Utility as RBU+import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad+import qualified Reactive.Banana.MIDI.Common as Common+import Reactive.Banana.MIDI.Common+          (PitchChannel(PitchChannel),+           PitchChannelVelocity(PitchChannelVelocity),+           fraction, )++import qualified Reactive.Banana.Combinators as RB+import qualified Reactive.Banana.Frameworks as RBF+import qualified Reactive.Banana.Switch as RBS+import Reactive.Banana.Combinators ((<@>), )++import qualified Sound.MIDI.Message.Class.Construct as Construct+import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Class.Query as Query+import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice+          (Pitch, Velocity, Controller, Program, fromPitch, )++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 qualified Control.Monad.Trans.State as MS++import qualified Data.Traversable as Trav+import Control.Monad (join, mplus, when, )+import Control.Applicative (pure, liftA2, (<*>), (<$>), )+import Data.Monoid (mempty, mappend, )+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Ord.HT (comparing, limit, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (catMaybes, )++import qualified Data.Map as Map+import qualified Data.List.Key as Key+import qualified Data.List.Match as Match+import qualified Data.List as List++import Prelude hiding (sequence, )+++type RelativeTicks   m = Time.T m Time.Relative Time.Ticks+type AbsoluteTicks   m = Time.T m Time.Absolute Time.Ticks+type RelativeSeconds m = Time.T m Time.Relative Time.Seconds++class Moment moment where+   liftMoment :: RBS.Moment t a -> moment t a++instance Moment RBS.Moment where+   liftMoment = id+++class (Moment reactor, Time.Timed reactor) => Reactor reactor where+   {- |+   Provide a function for registering future beats+   and the return the reactive event list+   that results from the sent beats.+   -}+   reserveSchedule ::+      (RBF.Frameworks t) =>+      reactor t+         ([AbsoluteTicks reactor] -> IO (), IO (),+          RB.Event t (AbsoluteTicks reactor))++reactimate ::+   (Moment reactor, RBF.Frameworks t) =>+   RB.Event t (IO ()) -> IxMonad.Wrap reactor t ()+reactimate = IxMonad.Wrap . liftMoment . RBF.reactimate++liftIO ::+   (Moment m, RBF.Frameworks t) =>+   IO a -> IxMonad.Wrap m t a+liftIO = IxMonad.Wrap . liftMoment . RBF.liftIO++++scheduleQueue ::+   (Reactor reactor, RBF.Frameworks t) =>+   RB.Behavior t (AbsoluteTicks reactor) ->+   RB.Event t (Common.Bundle reactor a) -> reactor t (RB.Event t a)+scheduleQueue times e = IxMonad.unwrap $ do+   (send, _cancel, eEcho) <- IxMonad.Wrap 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, return () {- "got echo for event: " ++ show x -}),+                 ({- Time.inc t lastTime -}+                  echoTime, xs)))+       add time new = do+          MS.modify $ \(lastTime, old) ->+             (time,+              Common.mergeStable+                 (EventList.fromAbsoluteEventListGen Time.subSat mempty $+                  EventListAbs.fromPairList $+                  map (\(Common.Future dt a) -> (dt, a)) $+                  List.sortBy (comparing Common.futureTime) new) $+              EventList.decreaseStart+                 (Time.subSat time lastTime) old)+          return (Nothing, send $ map (flip Time.inc time . Common.futureTime) new)++       -- (Queue that keeps track of events to schedule+       -- , duration of the new alarm if applicable)+       (eEchoEvent, _bQueue) =+          RBU.sequence (mempty, EventList.empty) $+          RB.union (fmap remove eEcho) (pure add <*> times <@> e)++   reactimate $ fmap snd eEchoEvent+   return $ RBU.mapMaybe fst eEchoEvent++++{- |+Generate an event at the first time point.+-}+initialEvent ::+   (Reactor reactor, RBF.Frameworks t) =>+   a -> reactor t (RB.Event t a)+initialEvent x = IxMonad.unwrap $ do+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   liftIO $ send [mempty]+   return $ fmap (const x) eEcho++++{- |+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 ::+   (Reactor reactor, RBF.Frameworks t) =>+   RB.Behavior t (RelativeTicks reactor) ->+   reactor t (RB.Event t (AbsoluteTicks reactor))+beat tempo = IxMonad.unwrap $ do+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule++   liftIO $ send [mempty]++   let next dt time = (time, send [Time.inc dt time])+       eEchoEvent = 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 RBU.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 ::+   (Reactor reactor, RBF.Frameworks t) =>+   RelativeTicks reactor ->+   RB.Behavior t (RelativeTicks reactor) ->+   reactor t (RB.Event t (AbsoluteTicks reactor))+beatQuant maxDur tempo = IxMonad.unwrap $ do+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule++   liftIO $ send [mempty]++   let next dt time = do+          complete <- MS.gets (>=1)+          when complete $ MS.modify (subtract 1)+          portion <- MS.get+          let dur = limit (mempty,maxDur) (Time.scaleCeiling (1-portion) dt)+          MS.modify (Time.div dur dt +)+          return+             (toMaybe complete time,+              send [Time.inc dur time]+              {- print (dur, time, dt, portion) -} )++       eEchoEvent =+          fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho++   reactimate $ fmap snd eEchoEvent+   return $ RBU.mapMaybe fst eEchoEvent+++beatVarNext ::+   AbsoluteTicks reactor ->+   MS.State+      (AbsoluteTicks reactor, Double, RelativeTicks reactor)+      (Maybe (AbsoluteTicks reactor), AbsoluteTicks reactor)+beatVarNext _t = do+   (t0,r,p) <- MS.get+   {-+   It should be t1==t,+   where t is the timestamp from an Echo message+   and t1 is the computed time.+   In principle we could use t,+   but this will be slightly later than the reference time t1.+   -}+   let t1 = Time.inc (Time.scale r p) t0+   MS.put (t1,1,p)+   return (Just t1, Time.inc p t1)++beatVarChange ::+   RelativeTicks reactor -> AbsoluteTicks reactor ->+   MS.State+      (AbsoluteTicks reactor, Double, RelativeTicks reactor)+      (AbsoluteTicks reactor)+beatVarChange p1 t1 = do+   (t0,r0,p0) <- MS.get+   let r1 = max 0 $ r0 - Time.div (Time.subSat t1 t0) p0+   MS.put (t1,r1,p1)+   return (Time.inc (Time.scale r1 p1) t1)++{- |+Similar to 'beat' but it reacts immediately to tempo changes.+This requires the ability of the backend (e.g. ALSA)+to cancel sent (Echo) messages+and it requires to know the precise time points of tempo changes,+thus we need the Discrete input instead of Behaviour+and we need a behaviour for the current time.+-}+beatVar ::+   (Reactor reactor, RBF.Frameworks t) =>+   RB.Behavior t (AbsoluteTicks reactor) ->+   RB.Behavior t (RelativeTicks reactor) ->+   reactor t (RB.Event t (AbsoluteTicks reactor))+beatVar time tempo = IxMonad.unwrap $ do+   (send, cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   let sendSingle = send . (:[])++   liftIO $ sendSingle mempty++   (tempoInit, tempoChanges) <-+      IxMonad.Wrap $ liftMoment $+      liftA2 (,) (RBF.initial tempo) (RBF.changes tempo)++   let next t = mapSnd sendSingle <$> beatVarNext t++       change p1 t1 = do+          ta <- beatVarChange p1 t1+          return (Nothing, cancel >> sendSingle ta)++       eEchoEvent =+          fst $ RBU.sequence (mempty, 0, tempoInit) $+          RB.union+             (fmap next eEcho)+             (fmap (flip change) time <@> tempoChanges)++   reactimate $ fmap snd eEchoEvent+   return $ RBU.mapMaybe fst eEchoEvent+++{- |+Demonstration of scheduleQueue.+For real use with ALSA you should prefer 'delay',+since this uses precisely timed delivery by ALSA.+-}+delaySchedule ::+   (Reactor reactor, RBF.Frameworks t) =>+   RelativeTicks reactor ->+   RB.Behavior t (AbsoluteTicks reactor) ->+   RB.Event t a -> reactor t (RB.Event t a)+delaySchedule dt times =+   scheduleQueue times .+   fmap ((:[]) . Common.Future dt)+++delay ::+   RelativeTicks m ->+   RB.Event t ev -> RB.Event t (Common.Future m ev)+delay dt =+   fmap (Common.Future dt)++delayAdd ::+   RelativeTicks m ->+   RB.Event t ev -> RB.Event t (Common.Future m ev)+delayAdd dt evs =+   RB.union (fmap Common.now evs) $ delay dt evs+++{- |+register pressed keys+-}+pressed ::+   (KeySet.C set, Ord key) =>+   set key value ->+   RB.Event f (Note.BoundaryExt key value) ->+   (RB.Event f [Note.Boundary key value], RB.Behavior f (set key value))+pressed empty =+   RBU.traverse empty KeySet.changeExt++latch ::+   (Ord key) =>+   RB.Event f (Note.Boundary key value) ->+   (RB.Event f (Note.Boundary key value),+    RB.Behavior f (Map.Map key value))+latch =+   mapPair (RB.filterJust, fmap KeySet.deconsLatch) .+   RBU.traverse KeySet.latch KeySet.latchChange+++controllerRaw ::+   (Check.C ev) =>+   Channel ->+   Controller ->+   Int ->+   RB.Event t ev -> RB.Behavior t Int+controllerRaw chan ctrl deflt =+   RB.stepper deflt .+   RBU.mapMaybe (Check.controller chan ctrl)++controllerExponential ::+   (Floating a, Check.C ev) =>+   Channel ->+   Controller ->+   a -> (a,a) ->+   RB.Event t ev -> RB.Behavior t a+controllerExponential chan ctrl deflt (lower,upper) =+   let k = log (upper/lower) / 127+   in  RB.stepper deflt .+       RBU.mapMaybe+          (fmap ((lower*) . exp . (k*) . fromIntegral)+              . Check.controller chan ctrl)++controllerLinear ::+   (Fractional a, Check.C ev) =>+   Channel ->+   Controller ->+   a -> (a,a) ->+   RB.Event t ev -> RB.Behavior t a+controllerLinear chan ctrl deflt (lower,upper) =+   let k = (upper-lower) / 127+   in  RB.stepper deflt .+       RBU.mapMaybe+          (fmap ((lower+) . (k*) . fromIntegral)+              . Check.controller chan ctrl)+++tempoCtrl ::+   (Check.C ev) =>+   Channel ->+   Controller ->+   RelativeTicks m ->+   (RelativeTicks m, RelativeTicks m) ->+   RB.Event t ev ->+   (RB.Behavior t (RelativeTicks m), RB.Event t ev)+tempoCtrl chan ctrl deflt (lower,upper) =+   mapFst (RB.stepper deflt) .+   RBU.partitionMaybe+      (fmap (Ctrl.duration (lower, upper))+          . Check.controller chan ctrl)+++{- |+Use a MIDI controller for selecting a note from a key set.+Only the pitch class of the keys is respected.+The controller behavior must be in the range 0-127.+This way, it accesses the whole range of MIDI notes.+The output note is stopped and a new note is played+whenever turning the knob alters the note pitch.+The advantage of the effect is that the pitch range of the knob+does not depend on the number of pressed keys.+The disadvantage is that there are distinct distances between the pitches.+-}+snapSelect ::+   (Moment moment, RBF.Frameworks t, KeySet.C set,+    Pitch.C pitch, Eq pitch, Eq value) =>+   RB.Behavior t (set pitch value) ->+   RB.Behavior t Int ->+   moment t (RB.Event t [Note.Boundary pitch value])+snapSelect set ctrl =+   liftMoment $+   fmap+      (flip RBU.mapAdjacent Nothing+         (\oldNote newNote ->+            let note on (pc, v) = Note.Boundary pc v on+            in  catMaybes [fmap (note False) oldNote,+                           fmap (note True) newNote])) $+   uniqueChanges $+   liftA2+      (\s x ->+         toMaybe (not $ null s) $+         Key.minimum (\(pc, _v) -> abs (fromPitch (Pitch.extract pc) - x)) $+         map (\(pc, v) -> (Pitch.toClosestOctave x pc, v)) s)+      (fmap KeySet.toList set) ctrl+++uniqueChanges ::+   (Moment moment, RBF.Frameworks t, Eq a) =>+   RB.Behavior t a -> moment t (RB.Event t a)+uniqueChanges x = liftMoment $ do+   x0 <- RBF.initial x+   xs <- RBF.changes x+   return $ RB.filterJust $+      flip RBU.mapAdjacent x0 (\old new -> toMaybe (new/=old) new) xs+++sweep ::+   (RBF.Frameworks t, Reactor reactor) =>+   RelativeSeconds reactor ->+   (Double -> Double) ->+   RB.Behavior t Double ->+   reactor t+      (RB.Event t (AbsoluteTicks reactor),+       RB.Behavior t Double)+sweep durSecs wave speed = IxMonad.unwrap $ do+   bt <-+      IxMonad.Wrap . beat . pure =<<+         IxMonad.Wrap (Time.ticksFromSeconds durSecs)+   let dur = realToFrac $ Time.unSeconds $ Time.decons durSecs+   return+      (bt,+       fmap wave $ RB.accumB 0 $+       fmap (\d _ phase -> fraction (phase + dur * d)) speed <@> bt)++makeControllerLinear ::+   (Construct.C msg) =>+   Channel -> Controller ->+   RB.Behavior t Int ->+   RB.Behavior t Int ->+   RB.Event t time -> RB.Behavior t Double ->+   RB.Event t msg+makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =+   pure+      (\y depth center _time ->+         curry (Construct.anyController chan) cc $+         round $ limit (0,127) $+         fromIntegral center + fromIntegral depth * y)+      <*> ctrl+      <*> depthCtrl+      <*> centerCtrl+      <@> bt++++cyclePrograms ::+   (Construct.C msg, Query.C msg) =>+   [Program] ->+   RB.Event t msg -> RB.Event t (Maybe msg)+cyclePrograms pgms =+   fst .+   RBU.traverse (cycle pgms)+      (Program.traverseSeek (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 ::+   (Construct.C msg, Query.C msg) =>+   RelativeTicks m -> [Program] ->+   RB.Behavior t (AbsoluteTicks m) ->+   RB.Event t msg -> RB.Event t (Maybe msg)+cycleProgramsDefer defer pgms times =+   fst .+   RBU.traverse (cycle pgms, mempty)+      (\(eventTime,e) ->+         fmap join $ Trav.sequence $+         mplus+            (flip fmap (Query.program e) $ \(_chan, pgm) ->+               AccState.lift AccTuple.first $+                  Program.seek (length pgms) pgm)+            (flip fmap (Program.maybeNoteOn e) $ \chan -> do+               blockTime <- MS.gets snd+               if eventTime < blockTime+                 then return Nothing+                 else do+                    AccState.set AccTuple.second $+                       Time.inc defer eventTime+                    AccState.lift AccTuple.first $+                       Program.next chan)) .+   RB.apply (fmap (,) times)+++noteSequence ::+   (Construct.C msg) =>+   RelativeTicks m ->+   Bool -> [Bool -> msg] ->+   Common.Bundle m msg+noteSequence stepTime on =+   zipWith Common.Future (iterate (mappend stepTime) mempty) .+   map ($on)++{- |+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 ::+   (Construct.C msg, KeySet.C set) =>+   RelativeTicks m ->+   RB.Behavior t (set PitchChannel Velocity) ->+   RB.Event t Bool ->+   RB.Event t (Common.Bundle m msg)+guitar stepTime pressd trigger =+   fst $+   RBU.traverse []+      (\(set, on) -> do+         played <- MS.get+         let toPlay =+                case KeySet.toList set of+                   [] -> []+                   list ->+                      fmap (\(PitchChannelVelocity pc v) -> Note.make pc v) $+                      Guitar.mapChordToString Guitar.stringPitches $+                      fmap (uncurry PitchChannelVelocity) list+         MS.put toPlay+         return $+            if on+              then+                 noteSequence stepTime False+                    (List.reverse played)+                 +++                 noteSequence stepTime True toPlay+              else+                 noteSequence stepTime False played+                 +++                 noteSequence stepTime True+                    (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 ::+   (Reactor reactor, RBF.Frameworks t,+    Query.C msg, Construct.C msg, Time.Quantity time) =>+   Channel ->+   Time.T reactor Time.Relative time ->+   Time.T reactor Time.Relative time ->+   [([Pitch], [Pitch])] ->+   RB.Behavior t (AbsoluteTicks reactor) ->+   RB.Event t msg ->+   reactor t (RB.Event t (Common.Bundle reactor msg))+trainer chan pauseSecs durationSecs sets0 times evs0 = IxMonad.unwrap $ do+   pause    <- IxMonad.Wrap $ Time.ticksFromAny pauseSecs+   duration <- IxMonad.Wrap $ Time.ticksFromAny durationSecs+   let makeSeq sets =+          case sets of+             (target, _) : _ ->+                (concat $+                 zipWith+                    (\t p ->+                       Note.bundle t duration+                          (PitchChannel p chan, Common.normalVelocity))+                    (iterate (mappend duration) pause) target,+                 mappend pause $ Time.scaleInt (length target) duration)+             [] -> ([], mempty)++   let (initial, initIgnoreUntil) = makeSeq sets0+   initEv <- IxMonad.Wrap $ initialEvent initial++   return $ RB.union initEv $ fst $+      flip (RBU.traverse (sets0, [], Time.inc initIgnoreUntil mempty))+         (fmap (,) times <@> evs0) $ \(time,ev) ->+      case Query.noteExplicitOff ev of+         Just (_chan, (_vel, pitch, True)) -> do+            ignoreUntil <- AccState.get AccTuple.third3+            if time <= ignoreUntil+              then return []+              else do+                 pressd <- AccState.get AccTuple.second3+                 let newPressd = pitch : 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 $+                               Time.inc newIgnoreUntil time+                            return notes+                         else return []+                    _ -> return []+         _ -> return []
+ src/Reactive/Banana/MIDI/Program.hs view
@@ -0,0 +1,135 @@+module Reactive.Banana.MIDI.Program (+   traverse, traverseSeek, next, seek, maybeNoteOn,+   asBanks,+   ) where++import qualified Sound.MIDI.Message.Class.Query as Query+import qualified Sound.MIDI.Message.Class.Construct as Construct++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Program, fromProgram, toProgram, )++import qualified Control.Monad.Trans.State as MS++import qualified Data.Traversable as Trav+import Control.Monad (join, mplus, )+import Data.Tuple.HT (mapFst, mapSnd, )+import Data.Maybe.HT (toMaybe, )+++next ::+   (Construct.C msg) =>+   Channel -> MS.State [Program] (Maybe msg)+next chan =+   MS.state $ \pgms ->+   case pgms of+      pgm:rest -> (Just $ Construct.program chan pgm, rest)+      [] -> (Nothing, [])++seek :: Int -> Program -> MS.State [Program] (Maybe msg)+seek maxSeek pgm =+   fmap (const Nothing) $+   MS.modify $+      uncurry (++) .+      mapFst (dropWhile (pgm/=)) .+      splitAt maxSeek+++{-+Maybe we should use @Stream Program@ instead of @[Program]@.+-}+{- |+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.+-}+traverse ::+   (Query.C msg, Construct.C msg) =>+   msg -> MS.State [Program] (Maybe msg)+traverse =+   fmap join . Trav.traverse next . maybeNoteOn++{- |+This function extends 'traverse'.+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.+-}+traverseSeek ::+   (Query.C msg, Construct.C msg) =>+   Int ->+   msg -> MS.State [Program] (Maybe msg)+traverseSeek maxSeek e =+   fmap join $ Trav.sequence $+   mplus+      (fmap next $ maybeNoteOn e)+      (fmap (seek maxSeek . snd) $ Query.program e)++maybeNoteOn :: (Query.C msg) => msg -> Maybe Channel+maybeNoteOn msg =+   Query.noteExplicitOff msg >>= \(c, (_p, _v, on)) -> toMaybe on c++++{- |+> > replace [1,2,3,4] 5 [10,11,12,13]+> (True,[10,11,2,13])+-}+replace :: Real i => [i] -> i -> [i] -> (Bool, [i])+replace (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:) $+              replace ns (pgm-n) ps+replace [] _ ps = (False, ps)++fromBanks :: Real i => [i] -> [i] -> i+fromBanks 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.++@asBanks 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. @asBanks [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@.+@asBanks [8,8]@ allows to select 64 instruments+by 16 program change buttons,+whereas @asBanks [8,4,4]@+allows to address the full range of MIDI 128 instruments+with the same number of buttons.+-}+asBanks ::+   (Query.C msg, Construct.C msg) =>+   [Int] ->+   msg -> MS.State [Int] msg+asBanks ns e =+   maybe+      (return e)+      (\(chan,pgm) -> do+          valid <- MS.state $ replace ns (fromProgram pgm)+          fmap (Construct.program chan) $+             if valid+               then MS.gets (toProgram . fromBanks ns)+               else return pgm) $+   Query.program e
+ src/Reactive/Banana/MIDI/Time.hs view
@@ -0,0 +1,147 @@+module Reactive.Banana.MIDI.Time where++import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad+import qualified Reactive.Banana.Frameworks as RBF++import qualified Numeric.NonNegative.Class as NonNeg++import Control.Applicative (Const(Const), )+import Data.Monoid (Monoid, mempty, mappend, )+import Data.Tuple.HT (mapPair, mapSnd, )+import Data.Ord.HT (comparing, )+import Data.Eq.HT (equating, )++import Prelude hiding (div, )++{- |+The 'T' types are used instead of floating point types,+because the latter ones caused unpredictable 'negative number' errors.+There should be a common denominator to all involved numbers.+This way we can prevent unlimited growth of denominators.+-}+-- the Const type helps us to avoid explicit kind signature extension+newtype T m t a = Cons (Const a (m () t))++instance Show a => Show (T m t a) where+   showsPrec n x =+      showParen (n>10) $+         showString "Time.cons " . shows (decons x)++instance Eq a => Eq (T m t a) where+   (==)  =  equating decons++instance Ord a => Ord (T m t a) where+   compare  =  comparing decons++cons :: a -> T m t a+cons = Cons . Const++decons :: T m t a -> a+decons (Cons (Const a)) = a++relative ::+   (Ord a, Monoid a) =>+   String -> a -> T m Relative a+relative name t =+   if t>=mempty+     then cons t+     else error $ name ++ ": negative time"+++data Absolute = Absolute+data Relative = Relative++newtype Seconds = Seconds {unSeconds :: Rational}+   deriving (Show, Eq, Ord)++newtype Ticks = Ticks {unTicks :: Integer}+   deriving (Show, Eq, Ord)++instance Monoid Seconds where+   mempty = Seconds 0+   mappend (Seconds x) (Seconds y) = Seconds $ x+y++instance Monoid Ticks where+   mempty = Ticks 0+   mappend (Ticks x) (Ticks y) = Ticks $ x+y+++instance (Monoid a) => Monoid (T m t a) where+   mempty = cons mempty+   mappend x y = cons $ mappend (decons x) (decons y)+++class RelativeC t where+instance RelativeC Relative where++{- |+Technically identical to NonNeg.C+but without connotation of non-negativity.+-}+class (Ord a, Monoid a) => Split a where+   split :: a -> a -> (a, (Bool, a))++instance Split Seconds where+   split = NonNeg.splitDefault unSeconds Seconds++instance Split Ticks where+   split = NonNeg.splitDefault unTicks Ticks+++instance (RelativeC t, Split a) => NonNeg.C (T m t a) where+   split x y =+      mapPair (cons, mapSnd cons) $ split (decons x) (decons y)+++class IxMonad.C m => Timed m where+   ticksFromSeconds :: (RBF.Frameworks s) => T m t Seconds -> m s (T m t Ticks)++class Quantity a where+   ticksFromAny :: (Timed m, RBF.Frameworks s) => T m t a -> m s (T m t Ticks)++instance Quantity Seconds where+   ticksFromAny = ticksFromSeconds++instance Quantity Ticks where+   ticksFromAny = IxMonad.point+++consRel :: String -> Rational -> T m Relative Seconds+consRel msg x =+   if x>=0+     then cons $ Seconds x+     else error $ msg ++ ": negative number"++inc ::+   (Monoid a) =>+   T m Relative a -> T m t a -> T m t a+inc dt t = cons $ mappend (decons t) (decons dt)++subSat ::+   Split a => T m t a -> T m t a -> T m Relative a+subSat t1 t0 =+   let (b,d) = snd $ split (decons t0) (decons t1)+   in  cons $ if b then d else mempty++{- |+'scale' could also be defined for 'Seconds',+however, repeated application of 'scale'+would yield unlimited growth of denominator.+This applies e.g. to controlled beat generation.+-}+scale, scaleCeiling :: Double -> T m Relative Ticks -> T m Relative Ticks+scale k t =+   cons $ Ticks $ round $ toRational k * getTicks t++scaleCeiling k t =+   cons $ Ticks $ ceiling $ toRational k * getTicks t++scaleInt :: Integral i => i -> T m Relative Ticks -> T m Relative Ticks+scaleInt k t =+   cons $ Ticks $ getTicks t * fromIntegral k++div :: T m Relative Ticks -> T m Relative Ticks -> Double+div dt1 dt0  =  getTicks dt1 / getTicks dt0++getTicks :: Num a => T m Relative Ticks -> a+getTicks = fromInteger . unTicks . decons
+ src/Reactive/Banana/MIDI/Training.hs view
@@ -0,0 +1,111 @@+module Reactive.Banana.MIDI.Training (+   all,+   intervals,+   twoNotes,+   threeNotes,+   reverseThreeNotes,+   sortThreeNotes,+   transposeTwoNotes,+   ) where++import qualified Reactive.Banana.MIDI.Pitch as Pitch+import Reactive.Banana.MIDI.Common (pitch, )+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 Pitch.increase 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 (Pitch.increase (Pitch.subtract p0 baseKey)) pso))+         (randomItem ps) (randomItem ps)) $+   concat $ zipWith replicate [3,6..] $+   drop 3 $ List.inits $+   notes
+ src/Reactive/Banana/MIDI/Trie.hs view
@@ -0,0 +1,44 @@+{- |+This module is only needed for DeBruijn sequence generation.+-}+module Reactive.Banana.MIDI.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"
+ src/Reactive/Banana/MIDI/Utility.hs view
@@ -0,0 +1,54 @@+-- basic reactive functions that could as well be in reactive-banana+module Reactive.Banana.MIDI.Utility where++import qualified Reactive.Banana.Combinators as RB++import qualified Control.Monad.Trans.State as MS++import Prelude hiding (sequence, )+++partition ::+   (a -> Bool) -> RB.Event f a -> (RB.Event f a, RB.Event f a)+partition p =+   (\x ->+      (fmap snd $ RB.filterE fst x,+       fmap snd $ RB.filterE (not . fst) x)) .+   fmap (\a -> (p a, a))++mapMaybe ::+   (a -> Maybe b) -> RB.Event f a -> RB.Event f b+mapMaybe f = RB.filterJust . fmap f++partitionMaybe ::+   (a -> Maybe b) -> RB.Event f a -> (RB.Event f b, RB.Event f a)+partitionMaybe f =+   (\x ->+      (mapMaybe fst x,+       mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .+   fmap (\a -> (f a, a))++bypass ::+   (a -> Maybe b) ->+   (RB.Event f a -> RB.Event f c) ->+   (RB.Event f b -> RB.Event f c) ->+   RB.Event f a -> RB.Event f c+bypass p fa fb evs =+   let (eb,ea) = partitionMaybe p evs+   in  RB.union (fb eb) (fa ea)++traverse ::+   s -> (a -> MS.State s b) -> RB.Event f a ->+   (RB.Event f b, RB.Behavior f s)+traverse s f = sequence s . fmap f++sequence ::+   s -> RB.Event f (MS.State s a) ->+   (RB.Event f a, RB.Behavior f s)+sequence s =+   RB.mapAccum s . fmap MS.runState+++mapAdjacent :: (a -> a -> b) -> a -> RB.Event f a -> RB.Event f b+mapAdjacent f a0 =+   fst . RB.mapAccum a0 . fmap (\new old -> (f old new, new))