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, )
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
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])
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
flipSeq :: Int -> [Int]
flipSeq n =
let incList m = map (\x -> mod (x+m) n)
recourse y =
let z = concatMap (flip incList y) [1 .. n1]
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
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..])
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..])
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)
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