reactive-balsa-0.0: src/Reactive/Banana/ALSA/Pattern.hs
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