{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Sound.MIDI.ALSA.Common where import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.RealTime as RealTime import qualified Sound.MIDI.ALSA as MALSA import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode import Sound.MIDI.ALSA (normalNoteFromEvent, ) import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, ) import qualified Data.EventList.Relative.TimeBody as EventList import Data.EventList.Relative.MixedBody ((/.), (./), ) import Data.Accessor.Basic ((^.), (^=), ) 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 Data.Tuple.HT (mapFst, mapSnd, ) import Data.Maybe (mapMaybe, ) import qualified System.Random as Rnd import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Bits as Bits import Data.Bits ((.&.), ) import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Reader as Reader import Control.Monad.Trans.Reader (ReaderT, ) import Control.Monad (guard, replicateM, ) import qualified Numeric.NonNegative.Class as NonNeg import qualified Data.Monoid as Mn import Data.Ratio ((%), ) import Data.Word (Word8, ) import Data.Int (Int32, ) import Prelude hiding (init, filter, reverse, ) -- * helper functions data Handle = Handle { sequ :: SndSeq.T SndSeq.DuplexMode, client :: Client.T, portPublic, portPrivate :: Port.T, queue :: Queue.T } init :: IO Handle init = do h <- SndSeq.open SndSeq.defaultName SndSeq.Block Client.setName h "Haskell-Filter" c <- Client.getId h ppublic <- Port.createSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric pprivate <- Port.createSimple h "private" (Port.caps [Port.capRead, Port.capWrite]) Port.typeMidiGeneric q <- Queue.alloc h let hnd = Handle h c ppublic pprivate q Reader.runReaderT setTimeStamping hnd return hnd exit :: Handle -> IO () exit h = do _ <- Event.outputPending (sequ h) Queue.free (sequ h) (queue h) Port.delete (sequ h) (portPublic h) Port.delete (sequ h) (portPrivate h) SndSeq.close (sequ h) with :: ReaderT Handle IO a -> IO a with f = SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do Client.setName h "Haskell-Filter" c <- Client.getId h Port.withSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric $ \ppublic -> do Port.withSimple h "private" (Port.caps [Port.capRead, Port.capWrite]) Port.typeMidiGeneric $ \pprivate -> do Queue.with h $ \q -> flip Reader.runReaderT (Handle h c ppublic pprivate q) $ setTimeStamping >> f -- | make ALSA set the time stamps in incoming events setTimeStamping :: ReaderT Handle IO () setTimeStamping = Reader.ReaderT $ \h -> do info <- PortInfo.get (sequ h) (portPublic h) PortInfo.setTimestamping info True PortInfo.setTimestampReal info True PortInfo.setTimestampQueue info (queue h) PortInfo.set (sequ h) (portPublic h) info startQueue :: ReaderT Handle IO () startQueue = Reader.ReaderT $ \h -> do Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing _ <- Event.drainOutput (sequ h) return () connect :: String -> String -> ReaderT Handle IO () connect fromName toName = Reader.ReaderT $ \h -> do from <- Addr.parse (sequ h) fromName to <- Addr.parse (sequ h) toName SndSeq.connectFrom (sequ h) (portPublic h) from SndSeq.connectTo (sequ h) (portPublic h) to connectTimidity :: ReaderT Handle IO () connectTimidity = connect "E-MU Xboard61" "TiMidity" connectLLVM :: ReaderT Handle IO () connectLLVM = connect "E-MU Xboard61" "Haskell-Synthesizer" connectSuperCollider :: ReaderT Handle IO () connectSuperCollider = connect "E-MU Xboard61" "Haskell-Supercollider" -- * send single events sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO () sendNote chan dur vel pit = let note = simpleNote chan pit vel t = incTime dur 0 in do outputEvent 0 (Event.NoteEv Event.NoteOn note) outputEvent t (Event.NoteEv Event.NoteOff note) sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO () sendKey chan noteOn vel pit = outputEvent 0 $ Event.NoteEv (if noteOn then Event.NoteOn else Event.NoteOff) (simpleNote chan pit vel) sendController :: Channel -> Controller -> Int -> ReaderT Handle IO () sendController chan ctrl val = outputEvent 0 $ Event.CtrlEv Event.Controller $ MALSA.controllerEvent chan ctrl (fromIntegral val) sendProgram :: Channel -> Program -> ReaderT Handle IO () sendProgram chan pgm = outputEvent 0 $ Event.CtrlEv Event.PgmChange $ MALSA.programChangeEvent chan pgm sendMode :: Channel -> Mode.T -> ReaderT Handle IO () sendMode chan mode = outputEvent 0 $ Event.CtrlEv Event.Controller $ MALSA.modeEvent chan mode -- * constructors channel :: Int -> Channel channel = ChannelMsg.toChannel pitch :: Int -> Pitch pitch = VoiceMsg.toPitch velocity :: Int -> Velocity velocity = VoiceMsg.toVelocity controller :: Int -> Controller controller = VoiceMsg.toController program :: Int -> Program program = VoiceMsg.toProgram normalVelocity :: VoiceMsg.Velocity normalVelocity = VoiceMsg.toVelocity VoiceMsg.normalVelocity -- * time {- | The 'Time' types are used instead of floating point types, because the latter ones caused unpredictable 'negative number' errors. The denominator must always be a power of 10, this way we can prevent unlimited grow of denominators. -} type TimeAbs = Rational newtype Time = Time {deconsTime :: Rational} deriving (Show, Eq, Ord, Num, Fractional) consTime :: String -> Rational -> Time consTime msg x = if x>=0 then Time x else error $ msg ++ ": negative number" incTime :: Time -> TimeAbs -> TimeAbs incTime dt t = t + deconsTime dt nano :: Num a => a nano = 1000^(3::Int) instance Mn.Monoid Time where mempty = Time 0 mappend (Time x) (Time y) = Time (x+y) instance NonNeg.C Time where split = NonNeg.splitDefault deconsTime Time -- * events makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T makeEvent h t e = Event.Cons { Event.highPriority = False , Event.tag = 0 , Event.queue = queue h , Event.timestamp = Event.RealTime (RealTime.fromInteger (round (t*nano))) , Event.source = Addr.Cons (client h) (portPublic h) , Event.dest = Addr.subscribers , Event.body = e } makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T makeEcho h t c = Event.Cons { Event.highPriority = False , Event.tag = 0 , Event.queue = queue h , Event.timestamp = Event.RealTime (RealTime.fromInteger (round (t*nano))) , Event.source = Addr.Cons (client h) (portPrivate h) , Event.dest = Addr.Cons (client h) (portPrivate h) , Event.body = Event.CustomEv Event.Echo c } outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO () outputEvent t ev = Reader.ReaderT $ \h -> Event.output (sequ h) (makeEvent h t ev) >> Event.drainOutput (sequ h) >> return () simpleNote :: Channel -> Pitch -> Velocity -> Event.Note simpleNote c p v = Event.simpleNote (MALSA.fromChannel c) (MALSA.fromPitch p) (MALSA.fromVelocity v) {- | The times are relative to the start time of the bundle and do not need to be ordered. -} type Bundle a = [(Time, a)] type EventDataBundle = Bundle Event.Data singletonBundle :: a -> Bundle a singletonBundle ev = [(0,ev)] immediateBundle :: [a] -> Bundle a immediateBundle = map ((,) 0) timeFromStamp :: Event.TimeStamp -> Time timeFromStamp t = case t of Event.RealTime rt -> consTime "time conversion" $ RealTime.toInteger rt % nano -- _ -> 0, _ -> error "unsupported time stamp type" defaultTempoCtrl :: (Channel,Controller) defaultTempoCtrl = (ChannelMsg.toChannel 0, VoiceMsg.toController 16) -- * effects {- | Transpose a note event by the given number of semitones. Non-note events are returned without modification. If by transposition a note leaves the range of representable MIDI notes, then we return Nothing. -} transpose :: Int -> Event.Data -> Maybe Event.Data transpose d e = case e of Event.NoteEv notePart note -> fmap (\p -> Event.NoteEv notePart $ (MALSA.notePitch ^= p) note) $ increasePitch d $ note ^. MALSA.notePitch _ -> Just e {- | Swap order of keys. Non-note events are returned without modification. If by reversing a note leaves the range of representable MIDI notes, then we return Nothing. -} reverse :: Event.Data -> Maybe Event.Data reverse e = case e of Event.NoteEv notePart note -> fmap (\p -> Event.NoteEv notePart $ (MALSA.notePitch ^= p) note) $ maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $ note ^. MALSA.notePitch _ -> Just e setChannel :: Channel -> Event.Data -> Event.Data setChannel chan e = case e of Event.NoteEv notePart note -> Event.NoteEv notePart $ (MALSA.noteChannel ^= chan) note Event.CtrlEv ctrlPart ctrl -> Event.CtrlEv ctrlPart $ (MALSA.ctrlChannel ^= chan) ctrl _ -> e {- | > > replaceProgram [1,2,3,4] 5 [10,11,12,13] > (True,[10,11,2,13]) -} replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32]) replaceProgram (n:ns) pgm pt = let (p,ps) = case pt of [] -> (0,[]) (x:xs) -> (x,xs) in if pgm [Int32] -> Int32 programFromBanks ns ps = foldr (\(n,p) s -> p+n*s) 0 $ zip ns ps {- | Interpret program changes as a kind of bank switches in order to increase the range of instruments that can be selected via a block of patch select buttons. @programAsBanks ns@ divides the first @sum ns@ instruments into sections of sizes @ns!!0, ns!!1, ...@. Each program in those sections is interpreted as a bank in a hierarchy, where the lower program numbers are the least significant banks. Programs from @sum ns@ on are passed through as they are. @product ns@ is the number of instruments that you can address using this trick. In order to avoid overflow it should be less than 128. E.g. @programAsBanks [n,m]@ interprets subsequent program changes to @a@ (@0<=a Event.Data -> State.State [Int32] Event.Data programsAsBanks ns e = case e of Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 -> let pgm = Event.ctrlValue ctrl (valid, ps1) = replaceProgram ns pgm ps0 in (Event.CtrlEv Event.PgmChange $ ctrl{Event.ctrlValue = if valid then programFromBanks ns ps1 else pgm}, ps1) _ -> return e nextProgram :: Event.Note -> State.State [Program] [Event.Data] nextProgram note = State.state $ \pgms -> case pgms of pgm:rest -> ([Event.CtrlEv Event.PgmChange $ Event.Ctrl { Event.ctrlChannel = Event.noteChannel note, Event.ctrlParam = 0, Event.ctrlValue = MALSA.fromProgram pgm}], rest) [] -> ([],[]) {- | 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] [Event.Data] traversePrograms e = fmap (++ [e]) $ case e of Event.NoteEv notePart note -> (case fst $ normalNoteFromEvent notePart note of Event.NoteOn -> nextProgram note _ -> return []) _ -> return [] {- | 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] [Event.Data] traverseProgramsSeek maxSeek e = fmap (++ [e]) $ case e of Event.NoteEv notePart note -> case fst $ normalNoteFromEvent notePart note of Event.NoteOn -> nextProgram note _ -> return [] Event.CtrlEv Event.PgmChange ctrl -> let pgm = ctrl ^. MALSA.ctrlProgram in fmap (const []) $ State.modify $ uncurry (++) . mapFst (dropWhile (pgm/=)) . splitAt maxSeek _ -> return [] reduceNoteVelocity :: Word8 -> Event.Note -> Event.Note reduceNoteVelocity decay note = note{Event.noteVelocity = let vel = Event.noteVelocity note in if vel==0 then 0 else vel - min decay (vel-1)} delayAdd :: Word8 -> Time -> Event.Data -> EventDataBundle delayAdd decay d e = singletonBundle e ++ case e of Event.NoteEv notePart note -> [(d, Event.NoteEv notePart $ reduceNoteVelocity decay note)] _ -> [] {- | Map NoteOn events to a controller value. This way you may play notes via the resonance frequency of a filter. -} controllerFromNote :: (Int -> Int) -> VoiceMsg.Controller -> Event.Data -> Maybe Event.Data controllerFromNote f ctrl e = case e of Event.NoteEv notePart note -> case fst $ normalNoteFromEvent notePart note of Event.NoteOn -> Just $ Event.CtrlEv Event.Controller $ MALSA.controllerEvent (note ^. MALSA.noteChannel) ctrl (fromIntegral $ f $ fromIntegral $ VoiceMsg.fromPitch $ note ^. MALSA.notePitch) Event.NoteOff -> Nothing _ -> Just e _ -> Just e type KeySet = Map.Map (Pitch, Channel) Velocity type KeyQueue = [((Pitch, Channel), Velocity)] eventsFromKey :: Time -> ((Pitch, Channel), Velocity) -> EventDataBundle eventsFromKey dur ((pit,chan), vel) = (0, Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) : (dur, Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) : [] selectFromLimittedChord :: Int -> Time -> KeyQueue -> EventDataBundle selectFromLimittedChord n dur = maybe [] (eventsFromKey dur) . (!!n) . (++ repeat Nothing) . map Just {- | 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 :: Int -> Time -> KeyQueue -> EventDataBundle selectFromOctaveChord d dur chord = maybe [] (eventsFromKey dur) $ do guard (not $ null chord) let (q,r) = divMod d (fromIntegral $ length chord) ((pit,chan), vel) = chord !! r transPitch <- increasePitch (12*q) pit return ((transPitch,chan), vel) selectFromChord :: Integer -> Time -> KeyQueue -> EventDataBundle selectFromChord d dur chord = if null chord then [] else eventsFromKey dur $ chord !! fromInteger d selectFromChordRatio :: Double -> Time -> KeyQueue -> EventDataBundle selectFromChordRatio d dur chord = if null chord then [] else eventsFromKey dur $ chord !! floor (d * fromIntegral (length chord)) 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 selectInversion :: Double -> Time -> KeyQueue -> EventDataBundle selectInversion d dur chord = let -- properFraction is useless for negative numbers splitFraction x = let n = floor x :: Int in (n, x - fromIntegral n) makeNote octave ((pit,chan), vel) = maybe [] (\pitchTrans -> eventsFromKey dur ((pitchTrans,chan), vel)) (increasePitch (octave*12) pit) (oct,p) = splitFraction d pivot = floor (p * fromIntegral (length chord)) (low,high) = splitAt pivot chord in concatMap (makeNote oct) high ++ concatMap (makeNote (oct+1)) low updateChord :: Event.NoteEv -> Event.Note -> KeySet -> KeySet updateChord notePart note = let key = (note ^. MALSA.notePitch, note ^. MALSA.noteChannel) (part, vel) = normalNoteFromEvent notePart note in case part of Event.NoteOn -> Map.insert key vel Event.NoteOff -> Map.delete key _ -> id controllerMatch :: Channel -> Controller -> Event.Ctrl -> Bool controllerMatch chan ctrl param = Event.ctrlChannel param == MALSA.fromChannel chan && Event.ctrlParam param == MALSA.fromController ctrl updateDur :: Event.Ctrl -> (Time, Time) -> Time updateDur = updateDurExponential updateDurLinear :: Event.Ctrl -> (Time, Time) -> Time updateDurLinear param (minDur, maxDur) = minDur + (maxDur-minDur) * fromIntegral (Event.ctrlValue param) / 127 updateDurExponential :: Event.Ctrl -> (Time, Time) -> Time updateDurExponential param (minDur, maxDur) = minDur * Time (powerRationalFromFloat 10 3 (fromRational $ deconsTime maxDur/deconsTime minDur :: Double) (fromIntegral (Event.ctrlValue param) / 127)) {- | Compute @base ** expo@ approximately to result type 'Rational' such that the result has a denominator which is a power of @digitBase@ and a relative precision of numerator of @precision@ digits with respect to @digitBase@-ary numbers. -} powerRationalFromFloat :: (Floating a, RealFrac a) => Int -> Int -> a -> a -> Rational powerRationalFromFloat digitBase precision base expo = let digitBaseFloat = fromIntegral digitBase {- It would be nice, if properFraction would warrant @0<=x<1@. Actually it can be @-1 Time -> KeyQueue -> EventDataBundle data PatternMono i = PatternMono (Selector i) [i] data IndexNote i = IndexNote Int i deriving (Show, Eq, Ord) item :: i -> Int -> IndexNote i item i n = IndexNote n i data PatternPoly i = PatternPoly (Selector i) (EventList.T Int [IndexNote i]) fraction :: RealFrac a => a -> a fraction x = let n = floor x in x - fromIntegral (n::Integer) data SweepState = SweepState { sweepSpeed, sweepDepth, sweepCenter, sweepPhase :: Double } {- ctrlRange :: (RealFrac b) => (b,b) -> (a -> b) -> (a -> Int) ctrlRange (l,u) f x = round $ limit (0,127) $ 127*(f x - l)/(u-l) -} -- * patterns {- | See Haskore/FlipSong flipSeq m !! n = cross sum of the m-ary representation of n modulo m. For m=2 this yields http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060 -} flipSeq :: Int -> [Int] flipSeq n = let incList m = map (\x -> mod (x+m) n) recourse y = let z = concatMap (flip incList y) [1 .. n-1] in z ++ recourse (y++z) in [0] ++ recourse [0] {- | @bruijn n k@ is a sequence with length n^k where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes. The function computes the lexicographically smallest of such sequences. -} bruijn :: Int -> Int -> [Int] bruijn n k = head $ bruijnAllMap n k {- | All Bruijn sequences with a certain -} bruijnAll :: Int -> Int -> [[Int]] bruijnAll 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) bruijnAllMap :: Int -> Int -> [[Int]] bruijnAllMap 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] testBruijn :: Int -> Int -> [Int] -> Bool testBruijn n k xs = replicateM k [0 .. n-1] == (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs) testBruijnAll :: Int -> Int -> Bool testBruijnAll n k = all (testBruijn n k) $ bruijnAllMap n k bruijnAllTrie :: Int -> Int -> [[Int]] bruijnAllTrie n k = let start = replicate k 0 go [] _ = error "infixes must have positive length" go (_:str) todo = case lookupWord str todo of Nothing -> do guard $ nullTrie todo return [] Just set -> do d <- set rest <- go (str ++ [d]) $ deleteWord d str todo return $ d:rest in map (take (n^k) . (start ++)) $ go start $ deleteWord 0 (tail start) $ fullTrie [0 .. n-1] [0 .. n-1] (k-1) data Trie a b = Leaf b | Branch [(a, Trie a b)] deriving (Show) fullTrie :: b -> [a] -> Int -> Trie a b fullTrie b _ 0 = Leaf b fullTrie b as n = Branch $ map (\a -> (a, fullTrie b as (n-1))) as nullTrie :: Trie a [b] -> Bool nullTrie (Branch []) = True nullTrie (Leaf []) = True nullTrie _ = False deleteWord :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b] deleteWord b [] (Leaf bs) = Leaf (List.delete b bs) deleteWord b (a:as) (Branch subTries) = Branch $ mapMaybe (\(key,trie) -> fmap ((,) key) $ if key==a then let delTrie = deleteWord b as trie in toMaybe (not (nullTrie delTrie)) delTrie else Just trie) subTries deleteWord _ _ _ = error "Trie.deleteWord: key and trie depth mismatch" lookupWord :: (Eq a) => [a] -> Trie a b -> Maybe b lookupWord [] (Leaf b) = Just b lookupWord (a:as) (Branch subTries) = lookup a subTries >>= lookupWord as lookupWord _ _ = error "Trie.lookupWord: key and trie depth mismatch" bruijnAllBits :: Int -> Int -> [[Int]] bruijnAllBits 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) cycleUp, cycleDown, pingPong, crossSum :: Int -> PatternMono Int cycleUp number = PatternMono selectFromLimittedChord (cycle [0..(number-1)]) cycleDown number = PatternMono selectFromLimittedChord (cycle $ List.reverse [0..(number-1)]) pingPong number = PatternMono selectFromLimittedChord $ cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)] crossSum number = PatternMono selectFromLimittedChord (flipSeq number) bruijnPat :: Int -> Int -> PatternMono Int bruijnPat n k = PatternMono selectFromLimittedChord $ cycle $ bruijn n k cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto :: PatternMono Integer cycleUpAuto = PatternMono (\ d dur chord -> selectFromChord (mod d (fromIntegral $ length chord)) dur chord) [0..] cycleDownAuto = PatternMono (\ d dur chord -> selectFromChord (mod d (fromIntegral $ length chord)) dur chord) [0,(-1)..] pingPongAuto = PatternMono (\ d dur chord -> let s = 2 * (fromIntegral (length chord) - 1) m = if s<=0 then 0 else min (mod d s) (mod (-d) s) in selectFromChord m dur chord) [0..] crossSumAuto = PatternMono (\ d dur chord -> let m = fromIntegral $ length chord s = if m <= 1 then 0 else sum $ decomposePositional m d in selectFromChord (mod s m) dur chord) [0..] binaryStaccato, binaryLegato, binaryAccident :: PatternPoly Int {- binary number patternMono: 0 1 0 1 2 0 2 1 2 0 1 2 3 -} binaryStaccato = PatternPoly selectFromLimittedChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (map (IndexNote 1 . fst) . List.filter ((/=0) . snd) . zip [0..] . decomposePositional 2) [0..]) binaryLegato = PatternPoly selectFromLimittedChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (\m -> map (uncurry IndexNote) $ List.filter (\(p,_i) -> mod m p == 0) $ takeWhile ((<=m) . fst) $ zip (iterate (2*) 1) [0..]) [0..]) {- This was my first try to implement binaryLegato. It was not what I wanted, but it sounded nice. -} binaryAccident = PatternPoly selectFromLimittedChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (zipWith IndexNote (iterate (2*) 1) . map fst . List.filter ((/=0) . snd) . zip [0..] . decomposePositional 2) [0..]) -- cf. htam:NumberTheory decomposePositional :: Integer -> Integer -> [Integer] decomposePositional b = let recourse 0 = [] recourse x = let (q,r) = divMod x b in r : recourse q in recourse cycleUpOctave :: Int -> PatternMono Int cycleUpOctave number = PatternMono selectFromOctaveChord (cycle [0..(number-1)]) random, randomInversions :: PatternMono Double random = PatternMono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42)) randomInversions = inversions $ map sum $ ListHT.sliceVertical 3 $ Rnd.randomRs (-1,1) $ Rnd.mkStdGen 42 cycleUpInversions :: Int -> PatternMono Double cycleUpInversions n = inversions $ cycle $ take n $ map (\i -> fromInteger i / fromIntegral n) [0..] inversions :: [Double] -> PatternMono Double inversions rs = PatternMono selectInversion rs {- 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. -} examplePatternPolyTempo0 :: EventList.T Int [IndexNote Int] examplePatternPolyTempo0 = 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 examplePatternPolyTempo1 :: EventList.T Int [IndexNote Int] examplePatternPolyTempo1 = 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 -- * predicates checkChannel :: (Channel -> Bool) -> (Event.Data -> Bool) checkChannel p e = case e of Event.NoteEv _notePart note -> p (note ^. MALSA.noteChannel) Event.CtrlEv Event.Controller ctrl -> p (ctrl ^. MALSA.ctrlChannel) _ -> False checkPitch :: (Pitch -> Bool) -> (Event.Data -> Bool) checkPitch p e = case e of Event.NoteEv _notePart note -> p (note ^. MALSA.notePitch) _ -> False checkController :: (Controller -> Bool) -> (Event.Data -> Bool) checkController p e = case e of Event.CtrlEv Event.Controller ctrlMode -> case ctrlMode ^. MALSA.ctrlControllerMode of MALSA.Controller ctrl _ -> p ctrl _ -> False _ -> False checkMode :: (Mode.T -> Bool) -> (Event.Data -> Bool) checkMode p e = case e of Event.CtrlEv Event.Controller ctrlMode -> case ctrlMode ^. MALSA.ctrlControllerMode of MALSA.Mode mode -> p mode _ -> False _ -> False checkProgram :: (Program -> Bool) -> (Event.Data -> Bool) checkProgram p e = case e of Event.CtrlEv Event.PgmChange ctrl -> p (ctrl ^. MALSA.ctrlProgram) _ -> False -- * 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)