diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Henning Thielemann +Copyright (c) 2012-2013, Henning Thielemann All rights reserved. diff --git a/reactive-balsa.cabal b/reactive-balsa.cabal --- a/reactive-balsa.cabal +++ b/reactive-balsa.cabal @@ -1,5 +1,5 @@ Name: reactive-balsa -Version: 0.1.1 +Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -40,18 +40,19 @@ Build-Type: Simple Source-Repository head type: darcs - location: http://code.haskell.org/~thielema/reactive-balsa/ + location: http://hub.darcs.net/thielema/reactive-balsa/ Source-Repository this type: darcs - location: http://code.haskell.org/~thielema/reactive-balsa/ - tag: 0.1.1 + location: http://hub.darcs.net/thielema/reactive-balsa/ + tag: 0.2 Flag splitBase description: Choose the new smaller, split-up base package. Library Build-Depends: + reactive-midyim >=0.2 && <0.3, reactive-banana >=0.7 && <0.8, midi-alsa >=0.2 && <0.3, midi >=0.2 && <0.3, @@ -61,9 +62,9 @@ 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, + utility-ht >=0.0.8 && <0.1, containers >=0.2 && <0.6, - transformers >=0.2 && <0.4, + transformers >=0.2 && <0.6, extensible-exceptions >=0.1 && <0.2 If flag(splitBase) Build-Depends: @@ -78,13 +79,7 @@ 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.Time Reactive.Banana.ALSA.Common - Reactive.Banana.ALSA.Utility Other-Modules: - Reactive.Banana.ALSA.DeBruijn - Reactive.Banana.ALSA.Trie + Reactive.Banana.ALSA.Private diff --git a/src/Reactive/Banana/ALSA/Common.hs b/src/Reactive/Banana/ALSA/Common.hs --- a/src/Reactive/Banana/ALSA/Common.hs +++ b/src/Reactive/Banana/ALSA/Common.hs @@ -1,7 +1,15 @@ module Reactive.Banana.ALSA.Common where -import qualified Reactive.Banana.ALSA.Time as Time +import qualified Reactive.Banana.ALSA.Private as Priv +import Reactive.Banana.ALSA.Private (Handle(..), ) +import qualified Reactive.Banana.ALSA.Time as AlsaTime +import qualified Reactive.Banana.MIDI.Time as Time + +import qualified Reactive.Banana.MIDI.Note as Note +import qualified Reactive.Banana.MIDI.Common as Common +import Reactive.Banana.MIDI.Common (VelocityField, singletonBundle, ) + import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client @@ -17,32 +25,22 @@ import qualified Foreign.C.Error as Err 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.ALSA.Construct () +import Sound.MIDI.ALSA.Query () 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 Control.Monad (mplus, ) +import Control.Functor.HT (void, ) +import Data.Maybe (maybeToList, ) import Data.List (intercalate, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Tuple.HT (mapFst, mapSnd, ) -import Data.Bool.HT (if', ) -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 Prelude hiding (init, filter, reverse, ) @@ -50,14 +48,6 @@ -- * 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 @@ -79,7 +69,7 @@ exit :: Handle -> IO () exit h = do - _ <- Event.outputPending (sequ h) + void $ Event.outputPending (sequ h) Queue.free (sequ h) (queue h) Port.delete (sequ h) (portPublic h) Port.delete (sequ h) (portPrivate h) @@ -114,8 +104,7 @@ startQueue :: ReaderT Handle IO () startQueue = Reader.ReaderT $ \h -> do Queue.control (sequ h) (queue h) Event.QueueStart Nothing - _ <- Event.drainOutput (sequ h) - return () + void $ Event.drainOutput (sequ h) {- | @@ -125,9 +114,8 @@ -} connect :: [String] -> [String] -> ReaderT Handle IO () connect fromNames toNames = do - _ <- connectFrom =<< parseAddresses fromNames - _ <- connectTo =<< parseAddresses toNames - return () + void $ connectFrom =<< parseAddresses fromNames + void $ connectTo =<< parseAddresses toNames connectFrom, connectTo :: Addr.T -> ReaderT Handle IO Connect.T connectFrom from = Reader.ReaderT $ \h -> @@ -176,69 +164,47 @@ -- * send single events -sendNote :: Channel -> Time.T -> Velocity -> Pitch -> ReaderT Handle IO () +sendNote :: Channel -> AlsaTime.RelativeTicks -> Velocity -> Pitch -> ReaderT Handle IO () sendNote chan dur vel pit = let note = simpleNote chan pit vel - t = Time.inc dur 0 - in do outputEvent 0 (Event.NoteEv Event.NoteOn note) + z = Mn.mempty + t = Time.inc dur z + in do outputEvent z (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 $ + outputEvent Mn.mempty $ 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 $ + outputEvent Mn.mempty $ Event.CtrlEv Event.Controller $ MALSA.controllerEvent chan ctrl (fromIntegral val) sendProgram :: Channel -> Program -> ReaderT Handle IO () sendProgram chan pgm = - outputEvent 0 $ + outputEvent Mn.mempty $ Event.CtrlEv Event.PgmChange $ MALSA.programChangeEvent chan pgm sendMode :: Channel -> Mode.T -> ReaderT Handle IO () sendMode chan mode = - outputEvent 0 $ + outputEvent Mn.mempty $ 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 - - - -defaultTempoCtrl :: (Channel,Controller) -defaultTempoCtrl = - (ChannelMsg.toChannel 0, VoiceMsg.toController 16) - +-- * events +class Reactor reactor where + reactorTime :: Time.T reactor t a -> Time.T Priv.Reactor t a --- * events +instance Reactor Priv.Reactor where + reactorTime = id {- | This class unifies several ways of handling multiple events at once. @@ -249,12 +215,16 @@ instance Events Event.Data where flattenEvents = singletonBundle -instance Events NoteBoundary where - flattenEvents = singletonBundle . noteFromBnd +instance + (Note.Make key, VelocityField value) => + Events (Note.Boundary key value) where + flattenEvents = singletonBundle . Note.fromBnd -instance Events ev => Events (Future ev) where - flattenEvents (Future dt ev) = - map (\(Future t e) -> Future (Mn.mappend t dt) e) $ +instance (Reactor m, Events ev) => Events (Common.Future m ev) where + flattenEvents (Common.Future dt ev) = + map + (\(Common.Future t e) -> + Common.Future (Mn.mappend t $ reactorTime dt) e) $ flattenEvents ev instance Events ev => Events (Maybe ev) where @@ -271,28 +241,27 @@ flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2 -makeEvent :: Handle -> Time.Abs -> Event.Data -> Event.T +makeEvent :: Handle -> AlsaTime.AbsoluteTicks -> Event.Data -> Event.T makeEvent h t e = (Event.simple (Addr.Cons (client h) (portPublic h)) e) { Event.queue = queue h - , Event.time = ATime.consAbs $ Time.toStamp t + , Event.time = ATime.consAbs $ AlsaTime.toStamp t } -makeEcho :: Handle -> Time.Abs -> Event.T +makeEcho :: Handle -> AlsaTime.AbsoluteTicks -> Event.T makeEcho h t = let addr = Addr.Cons (client h) (portPrivate h) in (Event.simple addr (Event.CustomEv Event.Echo (Event.Custom 0 0 0))) { Event.queue = queue h - , Event.time = ATime.consAbs $ Time.toStamp t + , Event.time = ATime.consAbs $ AlsaTime.toStamp t , Event.dest = addr } -outputEvent :: Time.Abs -> Event.Data -> ReaderT Handle IO () +outputEvent :: AlsaTime.AbsoluteTicks -> Event.Data -> ReaderT Handle IO () outputEvent t ev = Reader.ReaderT $ \h -> Event.output (sequ h) (makeEvent h t ev) >> - Event.drainOutput (sequ h) >> - return () + void (Event.drainOutput (sequ h)) simpleNote :: Channel -> Pitch -> Velocity -> Event.Note @@ -303,66 +272,14 @@ (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.T, futureData :: a} -type Bundle a = [Future a] +type Future = Common.Future Priv.Reactor +type Bundle a = Common.Bundle Priv.Reactor a type EventBundle = Bundle Event.T type EventDataBundle = Bundle Event.Data -singletonBundle :: a -> Bundle a -singletonBundle ev = [now ev] -immediateBundle :: [a] -> Bundle a -immediateBundle = map now - -now :: a -> Future a -now = Future Mn.mempty - -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 = @@ -375,247 +292,16 @@ (MALSA.ctrlChannel ^= chan) ctrl _ -> e -{- | -> > replaceProgram [1,2,3,4] 5 [10,11,12,13] -> (True,[10,11,2,13]) --} -replaceProgram :: Real i => [i] -> i -> [i] -> (Bool, [i]) -replaceProgram (n:ns) pgm pt = - let (p,ps) = - case pt of - [] -> (0,[]) - (x:xs) -> (x,xs) - in if pgm [i] -> [i] -> i -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 - Event.Data -> State.State [Int] 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 (fromIntegral $ Event.unValue pgm) ps0 - in (Event.CtrlEv Event.PgmChange $ - ctrl{Event.ctrlValue = - if valid - then Event.Value $ fromIntegral $ 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 = Event.Parameter 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 :: - Event.Velocity -> Event.Note -> Event.Note -reduceNoteVelocity (Event.Velocity decay) note = - note{Event.noteVelocity = - let Event.Velocity vel = Event.noteVelocity note - in if vel==0 - then Event.offVelocity - else Event.Velocity $ vel - min decay (vel-1)} - delayAdd :: - Event.Velocity -> Time.T -> Event.Data -> EventDataBundle + Velocity -> AlsaTime.RelativeTicks -> Event.Data -> EventDataBundle delayAdd decay d e = singletonBundle e ++ - case e of - Event.NoteEv notePart note -> - [Future d $ - Event.NoteEv notePart $ - reduceNoteVelocity decay note] - _ -> [] + (maybeToList $ fmap (Common.Future d) $ + Note.lift (Note.reduceVelocity decay) e) -{- | -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.T -> Time.T -> ((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) - - -fraction :: RealFrac a => a -> a -fraction x = - let n = floor x - in x - fromIntegral (n::Integer) - - -ctrlDur :: - (Time.T, Time.T) -> Int -> Time.T -ctrlDur = ctrlDurExponential - -ctrlDurLinear :: - (Time.T, Time.T) -> Int -> Time.T -ctrlDurLinear (minDur, maxDur) val = - let k = fromIntegral val / 127 - in Time.scale (1-k) minDur `Mn.mappend` Time.scale k maxDur --- minDur + Time.scale (fromIntegral val / 127) (maxDur-minDur) - -ctrlDurExponential :: - (Time.T, Time.T) -> Int -> Time.T -ctrlDurExponential (minDur, maxDur) val = - Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur - - -{- -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 :: @@ -681,58 +367,3 @@ checkMode $ \mode -> mode == Mode.AllSoundOff || mode == Mode.AllNotesOff - - - -data NoteBoundary = - NoteBoundary (Pitch, Channel) Velocity Bool - deriving (Eq, Show) - -data NoteBoundaryExt = - NoteBoundaryExt NoteBoundary - | AllNotesOff - deriving (Eq, Show) - -maybeNote :: Event.Data -> Maybe NoteBoundary -maybeNote ev = - case ev of - Event.NoteEv notePart note -> - let key = - (note ^. MALSA.notePitch, - note ^. MALSA.noteChannel) - in case normalNoteFromEvent notePart note of - (Event.NoteOn, vel) -> Just $ NoteBoundary key vel True - (Event.NoteOff, vel) -> Just $ NoteBoundary key vel False - _ -> Nothing - _ -> Nothing - -maybeNoteExt :: Event.Data -> Maybe NoteBoundaryExt -maybeNoteExt ev = - mplus - (fmap NoteBoundaryExt $ maybeNote ev) - (toMaybe (isAllNotesOff ev) AllNotesOff) - -noteFromBnd :: NoteBoundary -> Event.Data -noteFromBnd (NoteBoundary (pit,chan) vel on) = - Event.NoteEv - (if' on Event.NoteOn Event.NoteOff) - (simpleNote chan pit vel) - - --- * 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) diff --git a/src/Reactive/Banana/ALSA/DeBruijn.hs b/src/Reactive/Banana/ALSA/DeBruijn.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/DeBruijn.hs +++ /dev/null @@ -1,138 +0,0 @@ -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' 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 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 diff --git a/src/Reactive/Banana/ALSA/Example.hs b/src/Reactive/Banana/ALSA/Example.hs --- a/src/Reactive/Banana/ALSA/Example.hs +++ b/src/Reactive/Banana/ALSA/Example.hs @@ -1,28 +1,39 @@ {-# LANGUAGE Rank2Types #-} module Reactive.Banana.ALSA.Example where -import qualified Reactive.Banana.ALSA.Training as Training -import qualified Reactive.Banana.ALSA.Pattern as Pattern -import qualified Reactive.Banana.ALSA.KeySet as KeySet import qualified Reactive.Banana.ALSA.Sequencer as Seq -import qualified Reactive.Banana.ALSA.Time as Time import qualified Reactive.Banana.ALSA.Common as Common -import Reactive.Banana.ALSA.Common - (NoteBoundaryExt(NoteBoundaryExt), NoteBoundary(NoteBoundary), - program, channel, pitch, controller, ) +import qualified Reactive.Banana.ALSA.Time as AlsaTime -import qualified Reactive.Banana.ALSA.Utility as RBU +import qualified Reactive.Banana.MIDI.Training as Training +import qualified Reactive.Banana.MIDI.Pattern as Pattern +import qualified Reactive.Banana.MIDI.Controller as Ctrl +import qualified Reactive.Banana.MIDI.Pitch as Pitch +import qualified Reactive.Banana.MIDI.KeySet as KeySet +import qualified Reactive.Banana.MIDI.Process as Process +import qualified Reactive.Banana.MIDI.Note as Note +import qualified Reactive.Banana.MIDI.Time as Time +import Reactive.Banana.MIDI.Common + (PitchChannel, + program, channel, pitch, controller, + singletonBundle, now, ) +import qualified Reactive.Banana.MIDI.Utility as RBU + import qualified Reactive.Banana.Frameworks as RBF import qualified Reactive.Banana.Combinators as RB import Reactive.Banana.Combinators ((<@>), ) -import qualified Sound.MIDI.Message.Class.Check as Check +import qualified Sound.MIDI.ALSA.Check as Check +import qualified Sound.MIDI.ALSA.Query as Query () +import qualified Sound.MIDI.ALSA.Construct as Construct () +import qualified Sound.ALSA.Sequencer.Event as Event +import Sound.MIDI.Message.Channel.Voice (Velocity, ) import qualified System.Random as Random import Control.Monad.Trans.Reader (ReaderT, ) -import Control.Monad (guard, ) +import Control.Monad (guard, liftM2, liftM3, ) import Control.Applicative (pure, (<*>), ) import Data.Tuple.HT (mapFst, ) import Data.Maybe (mapMaybe, ) @@ -30,7 +41,7 @@ import Prelude hiding (reverse, ) -run, runLLVM, runTimidity :: ReaderT Common.Handle IO a -> IO a +run, runLLVM, runTimidity :: ReaderT Seq.Handle IO a -> IO a run x = Common.with $ Common.connectAny >> x runLLVM x = Common.with $ Common.connectLLVM >> x runTimidity x = Common.with $ Common.connectTimidity >> x @@ -60,56 +71,72 @@ sweep, guitar, snapSelect, - continuousSelect :: ReaderT Common.Handle IO () + continuousSelect :: ReaderT Seq.Handle IO () -time :: Rational -> Time.T -time = Time.cons "example" +time :: Rational -> AlsaTime.RelativeSeconds +time = Time.relative "example" . Time.Seconds +ticks :: + (RBF.Frameworks t) => + Rational -> Seq.Reactor t AlsaTime.RelativeTicks +ticks = Time.ticksFromSeconds . time + +{- +stranspose :: + (Query.C msg, Construct.C msg) => Int -> msg -> Maybe msg +-} +stranspose :: Int -> Event.Data -> Maybe Event.Data +stranspose d = Note.liftMaybe $ Note.transpose d + pass = Seq.run id -transpose = Seq.run $ RBU.mapMaybe $ Common.transpose 2 -reverse = Seq.run $ RBU.mapMaybe $ Common.reverse --- works, but does not interact nicely with AllNotesOff +transpose = Seq.run $ RBU.mapMaybe $ stranspose 2 +reverse = Seq.run $ RBU.mapMaybe $ Note.liftMaybe Note.reverse +-- works, but does not interact nicely with Note.AllOff -- latch = Seq.run (Seq.bypass Common.maybeNote (fst . Seq.latch)) -latch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.latch)) -groupLatch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.groupLatch)) -delay = Seq.run (Seq.delay $ time 0.2) -delayAdd = Seq.run (Seq.delayAdd $ time 0.2) -delayTranspose = Seq.run $ \ evs -> - let proc p dt = - Seq.delay (time dt) $ - RBU.mapMaybe (Common.transpose p) evs - evs1 = proc 4 0.2 - evs2 = proc 7 0.4 - evs3 = proc 12 0.6 - in foldl RB.union (fmap Common.now evs) [evs1, evs2, evs3] +latch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.latch)) +groupLatch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.groupLatch)) +delay = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delay dt evs +delayAdd = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delayAdd dt evs +delayTranspose = Seq.runM $ \ _times evs -> do + let proc p dt = do + tk <- ticks dt + return $ + Process.delay tk $ + RBU.mapMaybe (stranspose p) evs + fmap (foldl RB.union (fmap now evs)) $ sequence $ + proc 4 0.2 : + proc 7 0.4 : + proc 12 0.6 : + [] getTempo :: - (Check.C ev) => - RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev) -getTempo = - uncurry Seq.tempoCtrl Common.defaultTempoCtrl - (time 0.15) (time 0.5, time 0.05) + (Check.C ev, RBF.Frameworks t) => + RB.Event t ev -> + Seq.Reactor t (RB.Behavior t AlsaTime.RelativeTicks, RB.Event t ev) +getTempo ctrl = + liftM3 (uncurry Process.tempoCtrl Ctrl.tempoDefault) + (ticks 0.15) (liftM2 (,) (ticks 0.5) (ticks 0.05)) (return ctrl) {- pure 0.2 -} pattern :: (KeySet.C set) => - set -> + set PitchChannel Velocity -> (forall t. (RBF.Frameworks t) => - RB.Behavior t set -> - RB.Event t Time.Abs -> - RB.Event t [NoteBoundary]) -> - ReaderT Common.Handle IO () + RB.Behavior t (set PitchChannel Velocity) -> + RB.Event t AlsaTime.AbsoluteTicks -> + RB.Event t [Note.Boundary PitchChannel Velocity]) -> + ReaderT Seq.Handle IO () pattern set pat = Seq.runM $ \ times evs0 -> do - let (tempo, evs1) = getTempo evs0 - beat <- Seq.beatVar times tempo + (tempo, evs1) <- getTempo evs0 + beat <- Process.beatVar times tempo return $ - Seq.bypass Common.maybeNoteExt + Seq.bypass Note.maybeBndExt (\notes -> - pat (snd $ Seq.pressed set notes) beat) evs1 + pat (snd $ Process.pressed set notes) beat) evs1 serialCycleUp @@ -129,21 +156,21 @@ \set -> Pattern.pingPong (fmap KeySet.size set) set cycleUpOffset :: - ReaderT Common.Handle IO () + ReaderT Seq.Handle IO () cycleUpOffset = Seq.runM $ \ times evs0 -> do - let (tempo, evs1) = getTempo evs0 - n = 4 + (tempo, evs1) <- getTempo evs0 + let n = 4 range = 3 * fromIntegral n offset = fmap round $ - Seq.controllerLinear (channel 0) (controller 17) + Process.controllerLinear (channel 0) (controller 17) (0::Float) (-range,range) evs1 - beat <- Seq.beatVar times tempo + beat <- Process.beatVar times tempo return $ - Seq.bypass Common.maybeNoteExt + Seq.bypass Note.maybeBndExt (\notes -> Pattern.mono Pattern.selectFromOctaveChord - (snd $ Seq.pressed KeySet.groupLatch notes) + (snd $ Process.pressed KeySet.groupLatch notes) (pure (\o i -> mod (i-o) n + o) <*> offset <@> Pattern.cycleUpIndex (pure n) beat)) evs1 @@ -153,28 +180,28 @@ fmap (Pattern.mono Pattern.selectFromOctaveChord - (snd $ Seq.pressed KeySet.groupLatch $ - RBU.mapMaybe Common.maybeNoteExt evs)) $ - Seq.uniqueChanges $ + (snd $ Process.pressed KeySet.groupLatch $ + RBU.mapMaybe Note.maybeBndExt evs)) $ + Process.uniqueChanges $ fmap round $ - Seq.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs + Process.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs snapSelect = Seq.runM $ \ _times evs -> do - Seq.snapSelect - (snd $ Seq.pressed KeySet.groupLatch $ RBU.mapMaybe Common.maybeNoteExt evs) - (Seq.controllerRaw (channel 0) (controller 17) 64 evs) + Process.snapSelect + (snd $ Process.pressed KeySet.groupLatch $ RBU.mapMaybe Note.maybeBndExt evs) + (Process.controllerRaw (channel 0) (controller 17) 64 evs) {- - let ctrl = Seq.controllerRaw (channel 0) (controller 17) 64 evs - Seq.bypass Common.maybeNoteExt + let ctrl = Process.controllerRaw (channel 0) (controller 17) 64 evs + Seq.bypass Note.maybeBndExt (\notes -> - Seq.snapSelect (snd $ Seq.pressed KeySet.groupLatch notes) ctrl) evs + Seq.snapSelect (snd $ Process.pressed KeySet.groupLatch notes) ctrl) evs -} split = Seq.run $ uncurry RB.union . mapFst - (RBU.mapMaybe (Common.transpose 12) + (RBU.mapMaybe (stranspose 12) . fmap (Common.setChannel (channel 1))) . @@ -187,34 +214,35 @@ splitPattern = Seq.runM $ \ times evs0 -> do - let (tempo, evs1) = getTempo evs0 - beat <- Seq.beatVar times tempo + (tempo, evs1) <- getTempo evs0 + beat <- Process.beatVar times tempo let checkLeft e = do - bnd <- Common.maybeNoteExt e + bnd <- Note.maybeBndExt e case bnd of - NoteBoundaryExt (NoteBoundary (pit,_chan) _vel _on) -> do - guard (pit < pitch 60) + Note.BoundaryExt (Note.Boundary pc _vel _on) -> do + guard (Pitch.extract pc < pitch 60) return bnd _ -> return bnd return $ Seq.bypass checkLeft (\left -> - fmap (mapMaybe (Common.transpose 12) . map Common.noteFromBnd) $ + fmap (mapMaybe (stranspose 12 . Note.fromBnd)) $ Pattern.cycleUp (pure 4) - (snd $ Seq.pressed KeySet.groupLatch left) beat) + (snd $ Process.pressed KeySet.groupLatch left) beat) evs1 {- - RBU.mapMaybe (Common.transpose 12) left)) beat + RBU.mapMaybe (stranspose 12) left)) beat -} -cyclePrograms = Seq.runM $ \times evs -> return $ +cyclePrograms = Seq.runM $ \times evs -> do -- Seq.cyclePrograms (map program [13..17]) times evs - RB.union + defer <- Time.ticksFromSeconds $ time 0.1 + return $ RB.union (RB.filterJust $ - Seq.cycleProgramsDefer (time 0.1) (map program [13..17]) times evs) + Process.cycleProgramsDefer defer (map program [13..17]) times evs) evs sweep = @@ -227,32 +255,36 @@ (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))) + (Process.makeControllerLinear c centerCC + (Process.controllerRaw c depthCC 64 evs) + (Process.controllerRaw c centerCC 64 evs))) $ - Seq.sweep + Process.sweep (time 0.01) (sin . (2*pi*)) - (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs) + (Process.controllerExponential c speedCC 0.3 (0.1, 1) evs) guitar = - Seq.run $ - Seq.bypass Common.maybeNoteExt $ \notes -> + Seq.runM $ \ _times evs -> + (\f -> fmap (flip f evs) (ticks 0.03)) $ \del -> + Seq.bypass Note.maybeBndExt $ \notes -> let (trigger, keys) = RBU.partitionMaybe (\note -> case note of - NoteBoundaryExt (NoteBoundary (pit,_chan) _vel on) -> do - guard $ pit == pitch 84 + Note.BoundaryExt (Note.Boundary pc _vel on) -> do + guard $ Pitch.extract pc == pitch 84 return on _ -> Nothing) notes - in Seq.guitar (time 0.03) (snd $ Seq.pressed KeySet.groupLatch keys) trigger + in (Process.guitar del + :: RB.Behavior t (KeySet.GroupLatch PitchChannel Velocity) -> + RB.Event t Bool -> RB.Event t Common.EventDataBundle) + (snd $ Process.pressed KeySet.groupLatch keys) trigger trainer :: (Random.RandomGen g) => - g -> ReaderT Common.Handle IO () + g -> ReaderT Seq.Handle IO () trainer g = Seq.runM $ \ times evs -> - fmap (RB.union (fmap Common.singletonBundle evs)) $ - Seq.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs + fmap (RB.union (fmap singletonBundle evs)) $ + Process.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs diff --git a/src/Reactive/Banana/ALSA/Guitar.hs b/src/Reactive/Banana/ALSA/Guitar.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/Guitar.hs +++ /dev/null @@ -1,37 +0,0 @@ --- 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)] diff --git a/src/Reactive/Banana/ALSA/KeySet.hs b/src/Reactive/Banana/ALSA/KeySet.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/KeySet.hs +++ /dev/null @@ -1,223 +0,0 @@ -module Reactive.Banana.ALSA.KeySet where - -import Reactive.Banana.ALSA.Common (NoteBoundary(NoteBoundary), ) - -import Sound.MIDI.Message.Channel (Channel, ) -import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, ) - -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, ) - - -{- -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 [NoteBoundary] - size :: set -> Int - toList :: set -> [((Pitch, Channel), Velocity)] - index :: Int -> set -> Maybe ((Pitch, Channel), Velocity) - change :: NoteBoundary -> MS.State set [NoteBoundary] - - - -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 bnd@(NoteBoundary key vel on) = do - AccState.modify pressedAcc $ - if on - then Map.insert key vel - else Map.delete key - return [bnd] - - - -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 :: - NoteBoundary -> - MS.State Latch (Maybe NoteBoundary) -latchChange (NoteBoundary key vel on) = - Trav.sequence $ toMaybe on $ do - isPressed <- MS.gets (Map.member key . deconsLatch) - if isPressed - then - AccState.modify latchAcc (Map.delete key) >> - return (NoteBoundary key vel False) - else - AccState.modify latchAcc (Map.insert key vel) >> - return (NoteBoundary key vel True) - -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 = fmap maybeToList . latchChange - - - -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 (NoteBoundary key vel on) = - if on - then 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 [NoteBoundary key vel True] - return $ - noteOffs ++ noteOn - else - AccState.modify groupLatchPressed (Set.delete key) >> - 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 bnd@(NoteBoundary 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 [] - -releasePlayedKeys :: - MS.State - (Map.Map (Pitch, Channel) Velocity) - [NoteBoundary] -releasePlayedKeys = - fmap (map (uncurry releaseKey) . Map.toList) $ - AccState.getAndModify Acc.self (const Map.empty) - -releaseKey :: - (Pitch, Channel) -> - Velocity -> NoteBoundary -releaseKey key vel = - NoteBoundary key vel False diff --git a/src/Reactive/Banana/ALSA/Pattern.hs b/src/Reactive/Banana/ALSA/Pattern.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/Pattern.hs +++ /dev/null @@ -1,403 +0,0 @@ -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 - (NoteBoundary(NoteBoundary), splitFraction, increasePitch, ) - -import qualified Reactive.Banana.ALSA.Utility as RBU -import qualified Reactive.Banana.Combinators as RB -import Reactive.Banana.Combinators ((<@>), ) - -import qualified Sound.MIDI.Message.Channel as ChannelMsg -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -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 = - RB.Behavior t set -> - RB.Event t time -> - RB.Event t [NoteBoundary] - -mono :: - (KeySet.C set) => - Selector set i -> - RB.Behavior t set -> - RB.Event t i -> - RB.Event t [NoteBoundary] -mono select pressed pattern = - fst $ RBU.sequence [] $ - pure - (\set i -> do - off <- MS.get - let mnote = select i set - on = - fmap - (\(key, vel) -> NoteBoundary key vel True) - mnote - MS.put $ fmap - (\(key, _vel) -> NoteBoundary key VoiceMsg.normalVelocity False) - mnote - return $ off ++ on) - <*> pressed - <@> pattern - - -poly :: - (KeySet.C set) => - Selector set i -> - RB.Behavior t set -> - RB.Event t [IndexNote i] -> - RB.Event t [NoteBoundary] -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)) -> - NoteBoundary key vel True) - sel - MS.put $ - EventList.mergeBy (\ _ _ -> False) laterOff $ - EventList.fromAbsoluteEventList $ - AbsEventList.fromPairList $ - List.sortBy (comparing fst) $ - map - (\(IndexNote dur (key, _vel)) -> - (dur, NoteBoundary key VoiceMsg.normalVelocity False)) - sel - return $ Fold.toList nowOff ++ on) - <*> pressed - <@> pattern - - - --- * selectors - -type Selector set i = - i -> set -> [((VoiceMsg.Pitch, ChannelMsg.Channel), VoiceMsg.Velocity)] - - -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 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 chord = - maybeToList $ 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 chord = - maybeToList $ KeySet.index n chord - -selectFromChordRatio :: - KeySet.C set => - Selector set Double -selectFromChordRatio d chord = - selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord - - -selectInversion :: - KeySet.C set => - Selector set Double -selectInversion d chord = - let makeNote octave ((pit,chan), vel) = - fmap - (\pitchTrans -> ((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 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 => - RB.Behavior t Int -> T t time set -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 => - Int -> Int -> T t time set -bruijn n k sets times = - mono selectFromChord sets $ - fromList (cycle $ DeBruijn.lexLeast n k) times - - -binaryStaccato, binaryLegato, binaryAccident :: - KeySet.C set => T t time set -{- -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 => - RB.Behavior t Int -> T t time set -cycleUpOctave numbers sets times = - mono selectFromOctaveChord sets (cycleUpIndex numbers times) - - -random, randomInversions :: - KeySet.C set => T t time set -random sets times = - mono selectFromChordRatio sets $ - fst $ RB.mapAccum (Rnd.mkStdGen 42) $ - fmap (const $ Rnd.randomR (0,1)) times - -randomInversions = - inversions $ - map sum $ - ListHT.sliceVertical 3 $ - Rnd.randomRs (-1,1) $ - Rnd.mkStdGen 42 - -cycleUpInversions :: KeySet.C set => Int -> T t time set -cycleUpInversions n = - inversions $ cycle $ take n $ - map (\i -> fromInteger i / fromIntegral n) [0..] - -inversions :: KeySet.C set => [Double] -> T t time set -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 diff --git a/src/Reactive/Banana/ALSA/Private.hs b/src/Reactive/Banana/ALSA/Private.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/ALSA/Private.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Reactive.Banana.ALSA.Private where + +import qualified Reactive.Banana.MIDI.Process as Process +import qualified Reactive.Banana.MIDI.Time as Time +import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad + +import qualified Reactive.Banana.Frameworks as RBF +import qualified Reactive.Banana.Switch as RBS + +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.Event as Event + +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.IO.Class (MonadIO, ) +import Control.Monad.Fix (MonadFix, ) +import Control.Applicative (Applicative, ) + + + +data Handle = + Handle { + sequ :: SndSeq.T SndSeq.DuplexMode, + client :: Client.T, + portPublic, portPrivate :: Port.T, + queue :: Queue.T + } + + +newtype Reactor t a = + Reactor { + runReactor :: + MR.ReaderT + (RBF.AddHandler Event.T, Handle) + (MS.StateT Schedule (RBS.Moment t)) + a + } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + + +instance Process.Moment Reactor where + liftMoment = Reactor . MT.lift . MT.lift + +instance IxMonad.C Reactor where + point = return + bind = (>>=) + +instance Time.Timed Reactor where + ticksFromSeconds = + return . + Time.cons . Time.Ticks . + round . (nano *) . + Time.unSeconds . Time.decons + + +nano :: Num a => a +nano = 1000^(3::Int) + + +{- +We need this to identify received Echo events. +We could also use the Custom fields of the Echo event +and would get a much larger range of Schedules, +but unfortunately we cannot use the Custom values +for selectively removing events from the output queue. +This is needed in our variable speed beat generator. + +In order to prevent shortage of Tags +we could reserve one tag for events that will never be canceled +and then use the Custom fields in order to further distinguish Echo messages. +-} +type Schedule = Event.Tag +{- +newtype Schedule = Schedule Word32 + deriving (Eq, Ord, Enum, Show) +-} diff --git a/src/Reactive/Banana/ALSA/Sequencer.hs b/src/Reactive/Banana/ALSA/Sequencer.hs --- a/src/Reactive/Banana/ALSA/Sequencer.hs +++ b/src/Reactive/Banana/ALSA/Sequencer.hs @@ -1,97 +1,42 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} -module Reactive.Banana.ALSA.Sequencer where +module Reactive.Banana.ALSA.Sequencer ( + Handle, + Reactor, + 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.KeySet as KeySet -import qualified Reactive.Banana.ALSA.Time as Time -import qualified Reactive.Banana.ALSA.Utility as RBU +import qualified Reactive.Banana.ALSA.Time as AlsaTime +import Reactive.Banana.ALSA.Private + (Reactor(Reactor, runReactor), Schedule, + Handle(sequ, client, portPrivate), ) +import qualified Reactive.Banana.MIDI.Time as Time +import qualified Reactive.Banana.MIDI.Process as Process +import qualified Reactive.Banana.MIDI.Utility as RBU +import Reactive.Banana.MIDI.Common (Future(Future), ) + 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.ALSA.Sequencer.Event.RemoveMonad as Remove 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, - fromPitch, toPitch, ) - -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, liftM2, guard, ) -import Control.Applicative (Applicative, pure, liftA2, (<*>), ) -import Data.Monoid (mempty, mappend, ) -import Data.Bool.HT (if', ) -import Data.Tuple.HT (mapPair, mapFst, ) -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 as List -import qualified Data.List.Key as Key -import qualified Data.List.Match as Match +import Control.Monad (forever, ) +import Control.Applicative (Applicative, pure, (<*>), ) +import Control.Functor.HT (void, ) +import Data.Monoid (mempty, ) import Prelude hiding (sequence, ) --- * make ALSA reactive - -newtype Reactor t a = - Reactor { - runReactor :: - MR.ReaderT - (RBF.AddHandler Event.T, Common.Handle) - (MS.StateT Schedule (RBS.Moment t)) - a - } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) - - -liftNetworkDescription :: RBS.Moment t a -> Reactor t a -liftNetworkDescription act = - Reactor $ MT.lift $ MT.lift act - - -{- -We need this to identify received Echo events. -We could also use the Custom fields of the Echo event -and would get a much larger range of Schedules, -but unfortunately we cannot use the Custom values -for selectively removing events from the output queue. -This is needed in our variable speed beat generator. - -In order to prevent shortage of Tags -we could reserve one tag for events that will never be canceled -and then use the Custom fields in order to further distinguish Echo messages. --} -type Schedule = Event.Tag -{- -newtype Schedule = Schedule Word32 - deriving (Eq, Ord, Enum, Show) --} - startSchedule :: Schedule startSchedule = Event.Tag 1 @@ -102,7 +47,7 @@ else Event.Tag $ succ s -getHandle :: Reactor t Common.Handle +getHandle :: Reactor t Handle getHandle = Reactor $ MR.asks snd run :: @@ -110,7 +55,7 @@ (forall t. (RBF.Frameworks t) => RB.Event t Event.Data -> RB.Event t ev) -> - ReaderT Common.Handle IO () + ReaderT Handle IO () run f = runM (\ _ts xs -> return $ f xs) @@ -118,9 +63,9 @@ (Common.Events ev) => (forall t. (RBF.Frameworks t) => - RB.Behavior t Time.Abs -> + RB.Behavior t AlsaTime.AbsoluteTicks -> RB.Event t Event.Data -> Reactor t (RB.Event t ev)) -> - ReaderT Common.Handle IO () + ReaderT Handle IO () runM f = do Common.startQueue MR.ReaderT $ \h -> do @@ -128,9 +73,7 @@ (addEchoHandler, runEchoHandler) <- RBF.newAddHandler (addTimeHandler, runTimeHandler) <- RBF.newAddHandler RBF.actuate =<< RBF.compile (do - time <- - fmap (RB.stepper 0) $ - RBF.fromAddHandler addTimeHandler + time <- RBF.fromChanges mempty addTimeHandler evs <- flip MS.evalStateT startSchedule . flip MR.runReaderT (addEchoHandler, h) @@ -141,22 +84,21 @@ RBF.reactimate $ pure (outputEvents h) <*> time <@> evs) forever $ do - ev <- Event.input (Common.sequ h) - runTimeHandler $ Time.fromEvent ev - if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h) + ev <- Event.input (sequ h) + runTimeHandler $ AlsaTime.fromEvent ev + if Event.dest ev == Addr.Cons (client h) (portPrivate h) then debug "input: echo" >> runEchoHandler ev else debug "input: event" >> runEventHandler ev outputEvents :: Common.Events evs => - Common.Handle -> Time.Abs -> evs -> IO () + Handle -> AlsaTime.AbsoluteTicks -> evs -> IO () outputEvents h time evs = do - mapM_ (Event.output (Common.sequ h)) $ - map (\(Common.Future dt body) -> + mapM_ (Event.output (sequ h)) $ + map (\(Future dt body) -> Common.makeEvent h (Time.inc dt time) body) $ Common.flattenEvents evs - _ <- Event.drainOutput (Common.sequ h) - return () + void $ Event.drainOutput (sequ h) checkSchedule :: Schedule -> Event.T -> Bool @@ -169,75 +111,34 @@ (RBF.Frameworks t) => RB.Event t (IO ()) -> Reactor t () reactimate evs = - Reactor $ MT.lift $ MT.lift $ RBF.reactimate evs + Process.liftMoment $ RBF.reactimate evs -sendEchos :: Common.Handle -> Schedule -> [Time.Abs] -> IO () +sendEchos :: Handle -> Schedule -> [AlsaTime.AbsoluteTicks] -> IO () sendEchos h sched echos = do flip mapM_ echos $ \time -> - Event.output (Common.sequ h) $ + Event.output (sequ h) $ (Common.makeEcho h time) { Event.tag = sched } - _ <- Event.drainOutput (Common.sequ h) + void $ Event.drainOutput (sequ h) debug "echos sent" -cancelEchos :: Common.Handle -> Schedule -> IO () +cancelEchos :: Handle -> Schedule -> IO () cancelEchos h sched = - Remove.run (Common.sequ h) $ do + Remove.run (sequ h) $ do Remove.setOutput Remove.setEventType Event.Echo Remove.setTag sched -reserveSchedule :: - (RBF.Frameworks t) => - Reactor t (RB.Event t Time.Abs, [Time.Abs] -> IO (), IO ()) -reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do - sched <- MS.get - MS.modify nextSchedule - eEcho <- - MT.lift $ - fmap (fmap Time.fromEvent . - RB.filterE (checkSchedule sched)) $ - RBF.fromAddHandler addH - return (eEcho, sendEchos h sched, cancelEchos h sched) - - -scheduleQueue :: - (RBF.Frameworks t, Show a) => - RB.Behavior t Time.Abs -> - RB.Event t (Common.Bundle a) -> Reactor t (RB.Event t 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), - ({- Time.inc t lastTime -} - echoTime, xs))) - add time new = do - MS.modify $ \(lastTime, old) -> - (time, - Common.mergeStable - (EventList.mapTime (Time.cons "scheduleQueue") $ - EventList.fromAbsoluteEventList $ - EventListAbs.fromPairList $ - map (\(Common.Future dt a) -> (Time.decons dt, a)) $ - List.sortBy (comparing Common.futureTime) new) $ - EventList.decreaseStart - (Time.cons "Causal.process.decreaseStart" - (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 (0, EventList.empty) $ - RB.union (fmap remove eEcho) (pure add <*> times <@> e) - - reactimate $ fmap snd eEchoEvent - return $ RBU.mapMaybe fst eEchoEvent +instance Process.Reactor Reactor where + reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do + sched <- MS.get + MS.modify nextSchedule + eEcho <- + MT.lift $ + fmap (fmap AlsaTime.fromEvent . + RB.filterE (checkSchedule sched)) $ + RBF.fromAddHandler addH + return (sendEchos h sched, cancelEchos h sched, eEcho) debug :: String -> IO () @@ -253,546 +154,3 @@ RB.Event f a -> RB.Event f [Common.Future Event.Data] bypass p f = RBU.bypass p (fmap Common.flattenEvents) (fmap Common.flattenEvents . f) - - --- * examples - -{- | -register pressed keys --} -pressed :: - (KeySet.C set) => - set -> - RB.Event f Common.NoteBoundaryExt -> - (RB.Event f [Common.NoteBoundary], RB.Behavior f set) -pressed empty = - RBU.traverse empty - (\e -> - case e of - Common.NoteBoundaryExt bnd -> KeySet.change bnd - Common.AllNotesOff -> KeySet.reset) - -latch :: - RB.Event f Common.NoteBoundary -> - (RB.Event f Common.NoteBoundary, - RB.Behavior f (Map.Map (Pitch, Channel) Velocity)) -latch = - mapPair (RB.filterJust, fmap KeySet.deconsLatch) . - RBU.traverse KeySet.latch KeySet.latchChange - -{- | -Demonstration of scheduleQueue, -but for real use prefer 'delay', -since this uses precisely timed delivery by ALSA. --} -delaySchedule :: - (RBF.Frameworks t) => - Time.T -> - RB.Behavior t Time.Abs -> - RB.Event t Event.Data -> Reactor t (RB.Event t Event.Data) -delaySchedule dt times = - scheduleQueue times . - fmap ((:[]) . Common.Future dt) - -delay :: - Time.T -> - RB.Event t ev -> RB.Event t (Common.Future ev) -delay dt = - fmap (Common.Future dt) - -delayAdd :: - Time.T -> - RB.Event t ev -> RB.Event t (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 :: - (RBF.Frameworks t) => - RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs) -beat tempo = do - (eEcho, send, _) <- reserveSchedule - - liftIO $ send [0] - - 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 :: - (RBF.Frameworks t) => - Time.T -> - RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs) -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 (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 - - -{- | -Similar to 'beat' but it reacts immediately to tempo changes. -This requires the ability of 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 :: - (RBF.Frameworks t) => - RB.Behavior t Time.Abs -> - RB.Behavior t Time.T -> - Reactor t (RB.Event t Time.Abs) -beatVar time tempo = do - (eEcho, send, cancel) <- reserveSchedule - - liftIO $ send [0] - - (tempoInit, tempoChanges) <- - Reactor $ MT.lift $ MT.lift $ - liftM2 (,) (RBF.initial tempo) (RBF.changes tempo) - - let change :: - Time.T -> Time.Abs -> - MS.State - (Time.Abs, Double, Time.T) - (Maybe Time.Abs, IO ()) - - next _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, send [Time.inc p t1]) - - change 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 - (Nothing, - cancel >> - send [Time.inc (Time.scale r1 p1) t1]) - - eEchoEvent = - fst $ RBU.sequence (0, 0, tempoInit) $ - RB.union - (fmap next eEcho) - (fmap (flip change) time <@> tempoChanges) - - reactimate $ fmap snd eEchoEvent - return $ RBU.mapMaybe fst eEchoEvent - - -tempoCtrl :: - (Check.C ev) => - Channel -> - Controller -> - Time.T -> (Time.T, Time.T) -> - RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev) -tempoCtrl chan ctrl deflt (lower,upper) = - mapFst (RB.stepper deflt) . - RBU.partitionMaybe - (fmap (Common.ctrlDur (lower, upper)) - . Check.controller chan ctrl) - - -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) - - -cyclePrograms :: - [Program] -> - RB.Event t Event.Data -> RB.Event t (Maybe Event.Data) -cyclePrograms pgms = - fst . - RBU.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 :: - Time.T -> [Program] -> - RB.Behavior t Time.Abs -> - RB.Event t Event.Data -> RB.Event t (Maybe Event.Data) -cycleProgramsDefer defer pgms times = - fst . - RBU.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 $ - Time.inc 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 :: - Time.T -> - Event.NoteEv -> [Event.Note] -> - Common.EventDataBundle -noteSequence stepTime onOff = - zipWith Common.Future (iterate (mappend stepTime) mempty) . - 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) => - Time.T -> - RB.Behavior t set -> - RB.Event t Bool -> - RB.Event t Common.EventDataBundle -guitar stepTime pressd trigger = - fst $ - RBU.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 RBU.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 :: - (RBF.Frameworks t) => - Channel -> - Time.T -> Time.T -> - [([Pitch], [Pitch])] -> - RB.Behavior t Time.Abs -> - RB.Event t Event.Data -> - Reactor t (RB.Event t 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 (mappend duration) pause) target, - mappend pause $ Time.scaleInt (length target) duration) - [] -> ([], mempty) - - let (initial, initIgnoreUntil) = makeSeq sets0 - getHandle >>= \h -> liftIO (outputEvents h 0 initial) - - return $ fst $ - flip (RBU.traverse (sets0, [], Time.inc 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 $ - Time.inc newIgnoreUntil time - return notes - else return [] - _ -> return [] - _ -> return [] - _ -> return [] - - -sweep :: - (RBF.Frameworks t) => - Time.T -> - (Double -> Double) -> - RB.Behavior t Double -> - Reactor t (RB.Event t Time.Abs, RB.Behavior t Double) -sweep dur wave speed = do - bt <- beat $ pure dur - let durD = realToFrac $ Time.decons dur - return - (bt, - fmap wave $ RB.accumB 0 $ - fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt) - -makeControllerLinear :: - Channel -> Controller -> - RB.Behavior t Int -> - RB.Behavior t Int -> - RB.Event t Time.Abs -> RB.Behavior t Double -> - RB.Event t 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 - - -{- | -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 a distinct distances between the pitches. --} -snapSelect :: - (RBF.Frameworks t, KeySet.C set) => - RB.Behavior t set -> - RB.Behavior t Int -> - Reactor t (RB.Event t [Event.Data]) --- RBS.Moment t (RB.Event t [Event.Data]) -snapSelect set ctrl = - liftNetworkDescription $ - fmap (fst . RB.mapAccum Nothing . - fmap (\newNote oldNote -> - (guard (newNote/=oldNote) >> - catMaybes [fmap (Event.NoteEv Event.NoteOff . - uncurry (uncurry Common.simpleNote)) oldNote, - fmap (Event.NoteEv Event.NoteOn . - uncurry (uncurry Common.simpleNote)) newNote], - newNote))) $ - RBF.changes $ - liftA2 - (\s x -> - toMaybe (not $ null s) $ - Key.minimum (\((_c,p), _v) -> abs (fromPitch p - x)) $ - map (\((p,c), v) -> ((c, transposeToClosestOctave x p), v)) s) - (fmap KeySet.toList set) ctrl - -transposeToClosestOctave :: Int -> Pitch -> Pitch -transposeToClosestOctave target sourceClass = - let t = target - s = fromPitch sourceClass - x = mod (s - t + 6) 12 + t - 6 - in toPitch $ - if' (x<0) (x+12) $ - if' (x>127) (x-12) x - -uniqueChanges :: - (RBF.Frameworks t, Eq a) => - RB.Behavior t a -> Reactor t (RB.Event t a) -uniqueChanges x = liftNetworkDescription $ do - x0 <- RBF.initial x - xs <- RBF.changes x - return $ RB.filterJust $ fst $ - RB.mapAccum x0 $ fmap (\new old -> (toMaybe (new/=old) new, new)) xs diff --git a/src/Reactive/Banana/ALSA/Time.hs b/src/Reactive/Banana/ALSA/Time.hs --- a/src/Reactive/Banana/ALSA/Time.hs +++ b/src/Reactive/Banana/ALSA/Time.hs @@ -1,80 +1,38 @@ module Reactive.Banana.ALSA.Time where +import qualified Reactive.Banana.MIDI.Time as Time +import Reactive.Banana.ALSA.Private (Reactor, ) + import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.RealTime as RealTime import qualified Sound.ALSA.Sequencer.Time as ATime -import qualified Numeric.NonNegative.Class as NonNeg - -import qualified Data.Monoid as Mn -import Data.Ratio ((%), ) - import Prelude hiding (div, ) -{- | -The 'T' 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 Abs = Rational -newtype T = Cons {decons :: Rational} - deriving (Show, Eq, Ord) -cons :: String -> Rational -> T -cons msg x = - if x>=0 - then Cons x - else error $ msg ++ ": negative number" +type AbsoluteTicks = Time.T Reactor Time.Absolute Time.Ticks +type RelativeTicks = Time.T Reactor Time.Relative Time.Ticks -inc :: T -> Abs -> Abs -inc dt t = t + decons dt +type AbsoluteSeconds = Time.T Reactor Time.Absolute Time.Seconds +type RelativeSeconds = Time.T Reactor Time.Relative Time.Seconds -subSat :: Abs -> Abs -> T -subSat t1 t0 = cons "Time.sub" $ max 0 $ t1 - t0 -scale :: Double -> T -> T -scale k (Cons t) = - cons "Time.scale" $ round (toRational k * t * nano) % nano -scaleCeiling :: Double -> T -> T -scaleCeiling k (Cons t) = - cons "Time.scaleCeiling" $ ceiling (toRational k * t * nano) % nano - -scaleInt :: Integral i => i -> T -> T -scaleInt k (Cons t) = - cons "Time.scaleInt" $ t * fromIntegral k - -div :: T -> T -> Double -div dt1 dt0 = - fromRational (decons dt1 / decons dt0) - -nano :: Num a => a -nano = 1000^(3::Int) - -instance Mn.Monoid T where - mempty = Cons 0 - mappend (Cons x) (Cons y) = Cons (x+y) - -instance NonNeg.C T where - split = NonNeg.splitDefault decons Cons - - -fromStamp :: ATime.Stamp -> Abs +fromStamp :: ATime.Stamp -> AbsoluteTicks fromStamp t = case t of ATime.Real rt -> - RealTime.toInteger rt % nano + Time.cons $ Time.Ticks $ RealTime.toInteger rt -- _ -> 0, _ -> error "unsupported time stamp type" -toStamp :: Abs -> ATime.Stamp +toStamp :: AbsoluteTicks -> ATime.Stamp toStamp t = - ATime.Real (RealTime.fromInteger (round (t*nano))) + ATime.Real $ RealTime.fromInteger $ Time.unTicks $ Time.decons t -fromEvent :: Event.T -> Abs +fromEvent :: Event.T -> AbsoluteTicks fromEvent ev = case Event.time ev of ATime.Cons ATime.Absolute stamp -> fromStamp stamp - _ -> error "timeFromEvent: we can only handle absolute time stamps" + _ -> error "Time.fromEvent: we can only handle absolute time stamps" diff --git a/src/Reactive/Banana/ALSA/Training.hs b/src/Reactive/Banana/ALSA/Training.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/Training.hs +++ /dev/null @@ -1,110 +0,0 @@ -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 diff --git a/src/Reactive/Banana/ALSA/Trie.hs b/src/Reactive/Banana/ALSA/Trie.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/Trie.hs +++ /dev/null @@ -1,44 +0,0 @@ -{- | -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" diff --git a/src/Reactive/Banana/ALSA/Utility.hs b/src/Reactive/Banana/ALSA/Utility.hs deleted file mode 100644 --- a/src/Reactive/Banana/ALSA/Utility.hs +++ /dev/null @@ -1,49 +0,0 @@ --- basic reactive functions that could as well be in reactive-banana -module Reactive.Banana.ALSA.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