module Reactive.Banana.ALSA.Pattern where import qualified Reactive.Banana.ALSA.KeySet as KeySet import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn import Reactive.Banana.ALSA.Common (Time, EventDataBundle, eventsFromKey, splitFraction, increasePitch, ) import qualified Data.EventList.Relative.TimeBody as EventList import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.List.HT as ListHT import qualified Data.List as List import qualified System.Random as Rnd import Control.Monad (guard, ) import Prelude hiding (init, filter, reverse, ) -- * selectors type Selector set i = i -> Time -> set -> EventDataBundle data Mono set i = Mono (Selector set i) [i] data IndexNote i = IndexNote Int i deriving (Show, Eq, Ord) item :: i -> Int -> IndexNote i item i n = IndexNote n i data Poly set i = Poly (Selector set i) (EventList.T Int [IndexNote i]) {- | Generate notes according to the key set, where notes for negative and too large indices are padded with keys that are transposed by octaves. -} selectFromOctaveChord :: KeySet.C set => Selector set Int selectFromOctaveChord d dur chord = maybe [] (eventsFromKey 0 dur) $ do let size = KeySet.size chord guard (size>0) let (q,r) = divMod d size ((pit,chan), vel) <- KeySet.index r chord transPitch <- increasePitch (12*q) pit return ((transPitch,chan), vel) selectFromChord :: KeySet.C set => Selector set Int selectFromChord n dur chord = maybe [] (eventsFromKey 0 dur) (KeySet.index n chord) selectFromChordRatio :: KeySet.C set => Selector set Double selectFromChordRatio d dur chord = selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) dur chord selectInversion :: KeySet.C set => Selector set Double selectInversion d dur chord = let makeNote octave ((pit,chan), vel) = maybe [] (\pitchTrans -> eventsFromKey 0 dur ((pitchTrans,chan), vel)) (increasePitch (octave*12) pit) (oct,p) = splitFraction d pivot = floor (p * fromIntegral (KeySet.size chord)) (low,high) = splitAt pivot $ KeySet.toList chord in concatMap (makeNote oct) high ++ concatMap (makeNote (oct+1)) low -- * patterns {- | See Haskore/FlipSong flipSeq m !! n = cross sum of the m-ary representation of n modulo m. For m=2 this yields http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060 -} flipSeq :: Int -> [Int] flipSeq n = let incList m = map (\x -> mod (x+m) n) recourse y = let z = concatMap (flip incList y) [1 .. n-1] in z ++ recourse (y++z) in [0] ++ recourse [0] {- | @bruijn n k@ is a sequence with length n^k where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes. The function computes the lexicographically smallest of such sequences. -} bruijn :: Int -> Int -> [Int] bruijn n k = DeBruijn.lexLeast n k cycleUp, cycleDown, pingPong, crossSum :: KeySet.C set => Int -> Mono set Int cycleUp number = Mono selectFromChord (cycle [0..(number-1)]) cycleDown number = Mono selectFromChord (cycle $ List.reverse [0..(number-1)]) pingPong number = Mono selectFromChord $ cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)] crossSum number = Mono selectFromChord (flipSeq number) bruijnPat :: KeySet.C set => Int -> Int -> Mono set Int bruijnPat n k = Mono selectFromChord $ cycle $ bruijn n k {- We should increment the index at each step and wrap around according to current chord. This way we avoid jumps in the pattern. cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto :: KeySet.C set => Mono set Integer cycleUpAuto = Mono (\ d dur chord -> selectFromChord (mod d (fromIntegral $ length chord)) dur chord) [0..] cycleDownAuto = Mono (\ d dur chord -> selectFromChord (mod d (fromIntegral $ length chord)) dur chord) [0,(-1)..] pingPongAuto = Mono (\ d dur chord -> let s = 2 * (fromIntegral (length chord) - 1) m = if s<=0 then 0 else min (mod d s) (mod (-d) s) in selectFromChord m dur chord) [0..] crossSumAuto = Mono (\ d dur chord -> let m = fromIntegral $ length chord s = if m <= 1 then 0 else sum $ decomposePositional m d in selectFromChord (mod s m) dur chord) [0..] -} binaryStaccato, binaryLegato, binaryAccident :: KeySet.C set => Poly set Int {- binary number Pattern.Mono: 0 1 0 1 2 0 2 1 2 0 1 2 3 -} binaryStaccato = Poly selectFromChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (map (IndexNote 1 . fst) . List.filter ((/=0) . snd) . zip [0..] . decomposePositional 2) [0..]) binaryLegato = Poly selectFromChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (\m -> map (uncurry IndexNote) $ List.filter (\(p,_i) -> mod m p == 0) $ takeWhile ((<=m) . fst) $ zip (iterate (2*) 1) [0..]) [0..]) {- This was my first try to implement binaryLegato. It was not what I wanted, but it sounded nice. -} binaryAccident = Poly selectFromChord (EventList.fromPairList $ zip (0 : repeat 1) $ map (zipWith IndexNote (iterate (2*) 1) . map fst . List.filter ((/=0) . snd) . zip [0..] . decomposePositional 2) [0..]) -- cf. htam:NumberTheory decomposePositional :: Integer -> Integer -> [Integer] decomposePositional b = let recourse 0 = [] recourse x = let (q,r) = divMod x b in r : recourse q in recourse cycleUpOctave :: KeySet.C set => Int -> Mono set Int cycleUpOctave number = Mono selectFromOctaveChord (cycle [0..(number-1)]) random, randomInversions :: KeySet.C set => Mono set Double random = Mono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42)) randomInversions = inversions $ map sum $ ListHT.sliceVertical 3 $ Rnd.randomRs (-1,1) $ Rnd.mkStdGen 42 cycleUpInversions :: KeySet.C set => Int -> Mono set Double cycleUpInversions n = inversions $ cycle $ take n $ map (\i -> fromInteger i / fromIntegral n) [0..] inversions :: KeySet.C set => [Double] -> Mono set Double inversions rs = Mono selectInversion rs -- * tests {- We cannot use cycle function here, because we need to cycle a Body-Time list which is incompatible to a Body-Body list, even if the end is never reached. -} examplePolyTempo0 :: EventList.T Int [IndexNote Int] examplePolyTempo0 = let pat = [item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /. [item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /. pat in 0 /. pat examplePolyTempo1 :: EventList.T Int [IndexNote Int] examplePolyTempo1 = let pat = [item 0 1] ./ 1 /. [item 2 1, item 3 1, item 4 1] ./ 1 /. [item 2 1, item 3 1, item 4 1] ./ 1 /. [item 1 1] ./ 1 /. [item 2 1, item 3 1, item 4 1] ./ 1 /. [item 2 1, item 3 1, item 4 1] ./ 1 /. pat in 0 /. pat