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