reactive-midyim-0.2: src/Reactive/Banana/MIDI/Pattern.hs
module Reactive.Banana.MIDI.Pattern where
import qualified Reactive.Banana.MIDI.Note as Note
import qualified Reactive.Banana.MIDI.KeySet as KeySet
import qualified Reactive.Banana.MIDI.DeBruijn as DeBruijn
import qualified Reactive.Banana.MIDI.Pitch as Pitch
import Reactive.Banana.MIDI.Common (splitFraction, )
import qualified Reactive.Banana.MIDI.Utility as RBU
import qualified Reactive.Banana.Combinators as RB
import Reactive.Banana.Combinators ((<@>), )
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.Message.Channel.Voice (Velocity, )
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 key value =
RB.Behavior t (set key value) ->
RB.Event t time ->
RB.Event t [Note.Boundary key value]
mono ::
(KeySet.C set) =>
Selector set key Velocity i ->
RB.Behavior t (set key Velocity) ->
RB.Event t i ->
RB.Event t [Note.Boundary key Velocity]
mono select pressed pattern =
fst $ RBU.sequence [] $
pure
(\set i -> do
off <- MS.get
let mnote = select i set
on =
fmap
(\(key, vel) -> Note.Boundary key vel True)
mnote
MS.put $ fmap
(\(key, _vel) -> Note.Boundary key VoiceMsg.normalVelocity False)
mnote
return $ off ++ on)
<*> pressed
<@> pattern
poly ::
(KeySet.C set) =>
Selector set key Velocity i ->
RB.Behavior t (set key Velocity) ->
RB.Event t [IndexNote i] ->
RB.Event t [Note.Boundary key Velocity]
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)) ->
Note.Boundary key vel True)
sel
MS.put $
EventList.mergeBy (\ _ _ -> False) laterOff $
EventList.fromAbsoluteEventList $
AbsEventList.fromPairList $
List.sortBy (comparing fst) $
map
(\(IndexNote dur (key, _vel)) ->
(dur, Note.Boundary key VoiceMsg.normalVelocity False))
sel
return $ Fold.toList nowOff ++ on)
<*> pressed
<@> pattern
-- * selectors
type Selector set key value i =
i -> set key value -> [(key, value)]
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 key value i =
Poly (Selector set key value 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, Ord pitch, Pitch.C pitch) =>
Selector set pitch value Int
selectFromOctaveChord d chord =
maybeToList $ do
let size = KeySet.size chord
guard (size>0)
let (q,r) = divMod d size
(pc, vel) <- KeySet.index r chord
pcTrans <- Pitch.increase (12*q) pc
return (pcTrans, vel)
selectFromChord ::
(KeySet.C set, Ord key) =>
Selector set key value Int
selectFromChord n chord =
maybeToList $ KeySet.index n chord
selectFromChordRatio ::
(KeySet.C set, Ord key) =>
Selector set key value Double
selectFromChordRatio d chord =
selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord
selectInversion ::
(KeySet.C set, Pitch.C pitch) =>
Selector set pitch value Double
selectInversion d chord =
let makeNote octave (pc, vel) =
fmap
(\pcTrans -> (pcTrans, vel))
(Pitch.increase (octave*12) pc)
(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, Ord key) =>
RB.Behavior t Int -> T t time set key Velocity
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, Ord key) =>
Int -> Int -> T t time set key Velocity
bruijn n k sets times =
mono selectFromChord sets $
fromList (cycle $ DeBruijn.lexLeast n k) times
binaryStaccato, binaryLegato, binaryAccident ::
(KeySet.C set, Ord key) => T t time set key Velocity
{-
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, Ord pitch, Pitch.C pitch) =>
RB.Behavior t Int -> T t time set pitch Velocity
cycleUpOctave numbers sets times =
mono selectFromOctaveChord sets (cycleUpIndex numbers times)
random ::
(KeySet.C set, Ord key) =>
T t time set key Velocity
random sets times =
mono selectFromChordRatio sets $
fst $ RB.mapAccum (Rnd.mkStdGen 42) $
fmap (const $ Rnd.randomR (0,1)) times
randomInversions ::
(KeySet.C set, Pitch.C pitch) =>
T t time set pitch Velocity
randomInversions =
inversions $
map sum $
ListHT.sliceVertical 3 $
Rnd.randomRs (-1,1) $
Rnd.mkStdGen 42
cycleUpInversions ::
(KeySet.C set, Pitch.C pitch) =>
Int -> T t time set pitch Velocity
cycleUpInversions n =
inversions $ cycle $ take n $
map (\i -> fromInteger i / fromIntegral n) [0..]
inversions ::
(KeySet.C set, Pitch.C pitch) =>
[Double] -> T t time set pitch Velocity
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