module Sound.MIDI.ALSA.Common where
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.MIDI.ALSA as MALSA
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel.Mode as Mode
import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )
import qualified Data.EventList.Relative.TimeBody as EventList
import Data.EventList.Relative.MixedBody ((/.), (./), )
import Data.Accessor.Basic ((^.), (^=), )
import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Maybe (mapMaybe, )
import qualified System.Random as Rnd
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Bits as Bits
import Data.Bits ((.&.), )
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, replicateM, )
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Data.Monoid as Mn
import Data.Ratio ((%), )
import Data.Word (Word8, )
import Data.Int (Int32, )
import Prelude hiding (init, filter, reverse, )
data Handle =
Handle {
sequ :: SndSeq.T SndSeq.DuplexMode,
client :: Client.T,
portPublic, portPrivate :: Port.T,
queue :: Queue.T
}
init :: IO Handle
init = do
h <- SndSeq.open SndSeq.defaultName SndSeq.Block
Client.setName h "Haskell-Filter"
c <- Client.getId h
ppublic <-
Port.createSimple h "inout"
(Port.caps [Port.capRead, Port.capSubsRead,
Port.capWrite, Port.capSubsWrite])
Port.typeMidiGeneric
pprivate <-
Port.createSimple h "private"
(Port.caps [Port.capRead, Port.capWrite])
Port.typeMidiGeneric
q <- Queue.alloc h
let hnd = Handle h c ppublic pprivate q
Reader.runReaderT setTimeStamping hnd
return hnd
exit :: Handle -> IO ()
exit h = do
_ <- Event.outputPending (sequ h)
Queue.free (sequ h) (queue h)
Port.delete (sequ h) (portPublic h)
Port.delete (sequ h) (portPrivate h)
SndSeq.close (sequ h)
with :: ReaderT Handle IO a -> IO a
with f =
SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
Client.setName h "Haskell-Filter"
c <- Client.getId h
Port.withSimple h "inout"
(Port.caps [Port.capRead, Port.capSubsRead,
Port.capWrite, Port.capSubsWrite])
Port.typeMidiGeneric $ \ppublic -> do
Port.withSimple h "private"
(Port.caps [Port.capRead, Port.capWrite])
Port.typeMidiGeneric $ \pprivate -> do
Queue.with h $ \q ->
flip Reader.runReaderT (Handle h c ppublic pprivate q) $
setTimeStamping >> f
setTimeStamping :: ReaderT Handle IO ()
setTimeStamping = Reader.ReaderT $ \h -> do
info <- PortInfo.get (sequ h) (portPublic h)
PortInfo.setTimestamping info True
PortInfo.setTimestampReal info True
PortInfo.setTimestampQueue info (queue h)
PortInfo.set (sequ h) (portPublic h) info
startQueue :: ReaderT Handle IO ()
startQueue = Reader.ReaderT $ \h -> do
Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing
_ <- Event.drainOutput (sequ h)
return ()
connect :: String -> String -> ReaderT Handle IO ()
connect fromName toName = Reader.ReaderT $ \h -> do
from <- Addr.parse (sequ h) fromName
to <- Addr.parse (sequ h) toName
SndSeq.connectFrom (sequ h) (portPublic h) from
SndSeq.connectTo (sequ h) (portPublic h) to
connectTimidity :: ReaderT Handle IO ()
connectTimidity =
connect "E-MU Xboard61" "TiMidity"
connectLLVM :: ReaderT Handle IO ()
connectLLVM =
connect "E-MU Xboard61" "Haskell-Synthesizer"
connectSuperCollider :: ReaderT Handle IO ()
connectSuperCollider =
connect "E-MU Xboard61" "Haskell-Supercollider"
sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()
sendNote chan dur vel pit =
let note = simpleNote chan pit vel
t = incTime dur 0
in do outputEvent 0 (Event.NoteEv Event.NoteOn note)
outputEvent t (Event.NoteEv Event.NoteOff note)
sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()
sendKey chan noteOn vel pit =
outputEvent 0 $
Event.NoteEv
(if noteOn then Event.NoteOn else Event.NoteOff)
(simpleNote chan pit vel)
sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()
sendController chan ctrl val =
outputEvent 0 $
Event.CtrlEv Event.Controller $
MALSA.controllerEvent chan ctrl (fromIntegral val)
sendProgram :: Channel -> Program -> ReaderT Handle IO ()
sendProgram chan pgm =
outputEvent 0 $
Event.CtrlEv Event.PgmChange $
MALSA.programChangeEvent chan pgm
sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()
sendMode chan mode =
outputEvent 0 $
Event.CtrlEv Event.Controller $
MALSA.modeEvent chan mode
channel :: Int -> Channel
channel = ChannelMsg.toChannel
pitch :: Int -> Pitch
pitch = VoiceMsg.toPitch
velocity :: Int -> Velocity
velocity = VoiceMsg.toVelocity
controller :: Int -> Controller
controller = VoiceMsg.toController
program :: Int -> Program
program = VoiceMsg.toProgram
normalVelocity :: VoiceMsg.Velocity
normalVelocity =
VoiceMsg.toVelocity VoiceMsg.normalVelocity
type TimeAbs = Rational
newtype Time = Time {deconsTime :: Rational}
deriving (Show, Eq, Ord, Num, Fractional)
consTime :: String -> Rational -> Time
consTime msg x =
if x>=0
then Time x
else error $ msg ++ ": negative number"
incTime :: Time -> TimeAbs -> TimeAbs
incTime dt t = t + deconsTime dt
nano :: Num a => a
nano = 1000^(3::Int)
instance Mn.Monoid Time where
mempty = Time 0
mappend (Time x) (Time y) = Time (x+y)
instance NonNeg.C Time where
split = NonNeg.splitDefault deconsTime Time
makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T
makeEvent h t e =
Event.Cons
{ Event.highPriority = False
, Event.tag = 0
, Event.queue = queue h
, Event.timestamp =
Event.RealTime (RealTime.fromInteger (round (t*nano)))
, Event.source = Addr.Cons (client h) (portPublic h)
, Event.dest = Addr.subscribers
, Event.body = e
}
makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T
makeEcho h t c =
Event.Cons
{ Event.highPriority = False
, Event.tag = 0
, Event.queue = queue h
, Event.timestamp =
Event.RealTime (RealTime.fromInteger (round (t*nano)))
, Event.source = Addr.Cons (client h) (portPrivate h)
, Event.dest = Addr.Cons (client h) (portPrivate h)
, Event.body = Event.CustomEv Event.Echo c
}
outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()
outputEvent t ev = Reader.ReaderT $ \h ->
Event.output (sequ h) (makeEvent h t ev) >>
Event.drainOutput (sequ h) >>
return ()
simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
simpleNote c p v =
Event.simpleNote
(MALSA.fromChannel c)
(MALSA.fromPitch p)
(MALSA.fromVelocity v)
type Bundle a = [(Time, a)]
type EventDataBundle = Bundle Event.Data
singletonBundle :: a -> Bundle a
singletonBundle ev = [(0,ev)]
immediateBundle :: [a] -> Bundle a
immediateBundle = map ((,) 0)
timeFromStamp :: Event.TimeStamp -> Time
timeFromStamp t =
case t of
Event.RealTime rt ->
consTime "time conversion" $
RealTime.toInteger rt % nano
_ -> error "unsupported time stamp type"
defaultTempoCtrl :: (Channel,Controller)
defaultTempoCtrl =
(ChannelMsg.toChannel 0, VoiceMsg.toController 16)
transpose ::
Int -> Event.Data -> Maybe Event.Data
transpose d e =
case e of
Event.NoteEv notePart note ->
fmap (\p ->
Event.NoteEv notePart $
(MALSA.notePitch ^= p) note) $
increasePitch d $
note ^. MALSA.notePitch
_ -> Just e
reverse ::
Event.Data -> Maybe Event.Data
reverse e =
case e of
Event.NoteEv notePart note ->
fmap (\p ->
Event.NoteEv notePart $
(MALSA.notePitch ^= p) note) $
maybePitch $ (60+64 ) $ VoiceMsg.fromPitch $
note ^. MALSA.notePitch
_ -> Just e
setChannel ::
Channel -> Event.Data -> Event.Data
setChannel chan e =
case e of
Event.NoteEv notePart note ->
Event.NoteEv notePart $
(MALSA.noteChannel ^= chan) note
Event.CtrlEv ctrlPart ctrl ->
Event.CtrlEv ctrlPart $
(MALSA.ctrlChannel ^= chan) ctrl
_ -> e
replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32])
replaceProgram (n:ns) pgm pt =
let (p,ps) =
case pt of
[] -> (0,[])
(x:xs) -> (x,xs)
in if pgm<n
then (True, pgm:ps)
else mapSnd (p:) $
replaceProgram ns (pgmn) ps
replaceProgram [] _ ps = (False, ps)
programFromBanks :: [Int32] -> [Int32] -> Int32
programFromBanks ns ps =
foldr (\(n,p) s -> p+n*s) 0 $
zip ns ps
programsAsBanks ::
[Int32] ->
Event.Data -> State.State [Int32] Event.Data
programsAsBanks ns e =
case e of
Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
let pgm = Event.ctrlValue ctrl
(valid, ps1) = replaceProgram ns pgm ps0
in (Event.CtrlEv Event.PgmChange $
ctrl{Event.ctrlValue =
if valid
then programFromBanks ns ps1
else pgm},
ps1)
_ -> return e
nextProgram :: Event.Note -> State.State [Program] [Event.Data]
nextProgram note =
State.state $ \pgms ->
case pgms of
pgm:rest ->
([Event.CtrlEv Event.PgmChange $
Event.Ctrl {
Event.ctrlChannel = Event.noteChannel note,
Event.ctrlParam = 0,
Event.ctrlValue = MALSA.fromProgram pgm}],
rest)
[] -> ([],[])
traversePrograms ::
Event.Data -> State.State [Program] [Event.Data]
traversePrograms e =
fmap (++ [e]) $
case e of
Event.NoteEv notePart note ->
(case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> nextProgram note
_ -> return [])
_ -> return []
traverseProgramsSeek ::
Int ->
Event.Data -> State.State [Program] [Event.Data]
traverseProgramsSeek maxSeek e =
fmap (++ [e]) $
case e of
Event.NoteEv notePart note ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> nextProgram note
_ -> return []
Event.CtrlEv Event.PgmChange ctrl ->
let pgm = ctrl ^. MALSA.ctrlProgram
in fmap (const []) $
State.modify $
uncurry (++) .
mapFst (dropWhile (pgm/=)) .
splitAt maxSeek
_ -> return []
reduceNoteVelocity ::
Word8 -> Event.Note -> Event.Note
reduceNoteVelocity decay note =
note{Event.noteVelocity =
let vel = Event.noteVelocity note
in if vel==0
then 0
else vel min decay (vel1)}
delayAdd ::
Word8 -> Time -> Event.Data -> EventDataBundle
delayAdd decay d e =
singletonBundle e ++
case e of
Event.NoteEv notePart note ->
[(d, Event.NoteEv notePart $
reduceNoteVelocity decay note)]
_ -> []
controllerFromNote ::
(Int -> Int) ->
VoiceMsg.Controller ->
Event.Data -> Maybe Event.Data
controllerFromNote f ctrl e =
case e of
Event.NoteEv notePart note ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn ->
Just $
Event.CtrlEv Event.Controller $
MALSA.controllerEvent
(note ^. MALSA.noteChannel)
ctrl
(fromIntegral $ f $
fromIntegral $ VoiceMsg.fromPitch $
note ^. MALSA.notePitch)
Event.NoteOff -> Nothing
_ -> Just e
_ -> Just e
type KeySet = Map.Map (Pitch, Channel) Velocity
type KeyQueue = [((Pitch, Channel), Velocity)]
eventsFromKey ::
Time -> ((Pitch, Channel), Velocity) ->
EventDataBundle
eventsFromKey dur ((pit,chan), vel) =
(0, Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) :
(dur, Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
[]
selectFromLimittedChord ::
Int ->
Time ->
KeyQueue ->
EventDataBundle
selectFromLimittedChord n dur =
maybe [] (eventsFromKey dur) .
(!!n) . (++ repeat Nothing) . map Just
selectFromOctaveChord ::
Int ->
Time ->
KeyQueue ->
EventDataBundle
selectFromOctaveChord d dur chord =
maybe [] (eventsFromKey dur) $ do
guard (not $ null chord)
let (q,r) = divMod d (fromIntegral $ length chord)
((pit,chan), vel) = chord !! r
transPitch <- increasePitch (12*q) pit
return ((transPitch,chan), vel)
selectFromChord ::
Integer ->
Time ->
KeyQueue ->
EventDataBundle
selectFromChord d dur chord =
if null chord
then []
else
eventsFromKey dur $
chord !! fromInteger d
selectFromChordRatio ::
Double ->
Time ->
KeyQueue ->
EventDataBundle
selectFromChordRatio d dur chord =
if null chord
then []
else
eventsFromKey dur $
chord !! floor (d * fromIntegral (length chord))
maybePitch :: Int -> Maybe Pitch
maybePitch p =
toMaybe
(VoiceMsg.fromPitch minBound <= p &&
p <= VoiceMsg.fromPitch maxBound)
(VoiceMsg.toPitch p)
increasePitch :: Int -> Pitch -> Maybe Pitch
increasePitch d p =
maybePitch $ d + VoiceMsg.fromPitch p
selectInversion ::
Double ->
Time ->
KeyQueue ->
EventDataBundle
selectInversion d dur chord =
let
splitFraction x =
let n = floor x :: Int
in (n, x fromIntegral n)
makeNote octave ((pit,chan), vel) =
maybe []
(\pitchTrans -> eventsFromKey dur ((pitchTrans,chan), vel))
(increasePitch (octave*12) pit)
(oct,p) = splitFraction d
pivot = floor (p * fromIntegral (length chord))
(low,high) = splitAt pivot chord
in concatMap (makeNote oct) high ++
concatMap (makeNote (oct+1)) low
updateChord ::
Event.NoteEv -> Event.Note ->
KeySet -> KeySet
updateChord notePart note =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
(part, vel) =
normalNoteFromEvent notePart note
in case part of
Event.NoteOn -> Map.insert key vel
Event.NoteOff -> Map.delete key
_ -> id
controllerMatch ::
Channel -> Controller -> Event.Ctrl -> Bool
controllerMatch chan ctrl param =
Event.ctrlChannel param == MALSA.fromChannel chan &&
Event.ctrlParam param == MALSA.fromController ctrl
updateDur ::
Event.Ctrl -> (Time, Time) -> Time
updateDur = updateDurExponential
updateDurLinear ::
Event.Ctrl -> (Time, Time) -> Time
updateDurLinear param (minDur, maxDur) =
minDur + (maxDurminDur)
* fromIntegral (Event.ctrlValue param) / 127
updateDurExponential ::
Event.Ctrl -> (Time, Time) -> Time
updateDurExponential param (minDur, maxDur) =
minDur *
Time
(powerRationalFromFloat 10 3
(fromRational $ deconsTime maxDur/deconsTime minDur :: Double)
(fromIntegral (Event.ctrlValue param) / 127))
powerRationalFromFloat ::
(Floating a, RealFrac a) =>
Int -> Int -> a -> a -> Rational
powerRationalFromFloat digitBase precision base expo =
let digitBaseFloat = fromIntegral digitBase
(n,x) = properFraction (logBase digitBaseFloat base * expo)
frac = round (digitBaseFloat ** (x + fromIntegral precision))
in fromInteger frac *
fromIntegral digitBase ^^ (nprecision)
type Selector i = i -> Time -> KeyQueue -> EventDataBundle
data PatternMono i = PatternMono (Selector i) [i]
data IndexNote i = IndexNote Int i
deriving (Show, Eq, Ord)
item :: i -> Int -> IndexNote i
item i n = IndexNote n i
data PatternPoly i = PatternPoly (Selector i) (EventList.T Int [IndexNote i])
fraction :: RealFrac a => a -> a
fraction x =
let n = floor x
in x fromIntegral (n::Integer)
data SweepState =
SweepState {
sweepSpeed, sweepDepth, sweepCenter, sweepPhase :: Double
}
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]
bruijn :: Int -> Int -> [Int]
bruijn n k =
head $ bruijnAllMap n k
bruijnAll :: Int -> Int -> [[Int]]
bruijnAll n k =
let start = replicate k 0
go _ str 0 = do
guard $ str==start
return []
go set str c = do
d <- [0 .. n1]
let newStr = tail str ++ [d]
guard $ Set.notMember newStr set
rest <- go (Set.insert newStr set) newStr (c1)
return $ d:rest
in map (ListHT.rotate (k)) $
go Set.empty start (n^k)
bruijnAllMap :: Int -> Int -> [[Int]]
bruijnAllMap n k =
let start = replicate k 0
delete d =
Map.update (\set ->
let newSet = Set.delete d set
in toMaybe (not $ Set.null newSet) newSet)
go [] _ = error "infixes must have positive length"
go (_:str) todo =
case Map.lookup str todo of
Nothing -> do
guard $ Map.null todo
return []
Just set -> do
d <- Set.toList set
rest <- go (str ++ [d]) $ delete d str todo
return $ d:rest
in map (take (n^k) . (start ++)) $
go start $
delete 0 (tail start) $
Map.fromAscList $
map (flip (,) $ Set.fromList [0 .. n1]) $
replicateM (k1) [0 .. n1]
testBruijn :: Int -> Int -> [Int] -> Bool
testBruijn n k xs =
replicateM k [0 .. n1]
==
(List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)
testBruijnAll :: Int -> Int -> Bool
testBruijnAll n k =
all (testBruijn n k) $ bruijnAllMap n k
bruijnAllTrie :: Int -> Int -> [[Int]]
bruijnAllTrie n k =
let start = replicate k 0
go [] _ = error "infixes must have positive length"
go (_:str) todo =
case lookupWord str todo of
Nothing -> do
guard $ nullTrie todo
return []
Just set -> do
d <- set
rest <- go (str ++ [d]) $ deleteWord d str todo
return $ d:rest
in map (take (n^k) . (start ++)) $
go start $
deleteWord 0 (tail start) $
fullTrie [0 .. n1] [0 .. n1] (k1)
data Trie a b = Leaf b | Branch [(a, Trie a b)]
deriving (Show)
fullTrie :: b -> [a] -> Int -> Trie a b
fullTrie b _ 0 = Leaf b
fullTrie b as n =
Branch $
map (\a -> (a, fullTrie b as (n1))) as
nullTrie :: Trie a [b] -> Bool
nullTrie (Branch []) = True
nullTrie (Leaf []) = True
nullTrie _ = False
deleteWord :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]
deleteWord b [] (Leaf bs) = Leaf (List.delete b bs)
deleteWord b (a:as) (Branch subTries) =
Branch $ mapMaybe
(\(key,trie) ->
fmap ((,) key) $
if key==a
then let delTrie = deleteWord b as trie
in toMaybe (not (nullTrie delTrie)) delTrie
else Just trie)
subTries
deleteWord _ _ _ = error "Trie.deleteWord: key and trie depth mismatch"
lookupWord :: (Eq a) => [a] -> Trie a b -> Maybe b
lookupWord [] (Leaf b) = Just b
lookupWord (a:as) (Branch subTries) =
lookup a subTries >>= lookupWord as
lookupWord _ _ = error "Trie.lookupWord: key and trie depth mismatch"
bruijnAllBits :: Int -> Int -> [[Int]]
bruijnAllBits n k =
let go code todo =
let shiftedCode = mod (code*n) (n^k)
in case Bits.shiftR todo shiftedCode .&. (2^n1) of
0 -> do
guard $ todo == 0
return []
set -> do
d <- [0 .. n1]
guard $ Bits.testBit set d
rest <-
let newCode = shiftedCode + d
in go newCode $ Bits.clearBit todo newCode
return $ d:rest
in map (take (n^k) . (replicate k 0 ++)) $
go 0 $ (2^n^k2 :: Integer)
cycleUp, cycleDown, pingPong, crossSum ::
Int -> PatternMono Int
cycleUp number =
PatternMono selectFromLimittedChord (cycle [0..(number1)])
cycleDown number =
PatternMono selectFromLimittedChord (cycle $ List.reverse [0..(number1)])
pingPong number =
PatternMono selectFromLimittedChord $
cycle $ [0..(number2)] ++ List.reverse [1..(number1)]
crossSum number =
PatternMono selectFromLimittedChord (flipSeq number)
bruijnPat :: Int -> Int -> PatternMono Int
bruijnPat n k =
PatternMono selectFromLimittedChord $ cycle $ bruijn n k
cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::
PatternMono Integer
cycleUpAuto =
PatternMono
(\ d dur chord ->
selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
[0..]
cycleDownAuto =
PatternMono
(\ d dur chord ->
selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
[0,(1)..]
pingPongAuto =
PatternMono
(\ 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 =
PatternMono
(\ 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 :: PatternPoly Int
binaryStaccato =
PatternPoly
selectFromLimittedChord
(EventList.fromPairList $
zip (0 : repeat 1) $
map
(map (IndexNote 1 . fst) .
List.filter ((/=0) . snd) .
zip [0..] .
decomposePositional 2)
[0..])
binaryLegato =
PatternPoly
selectFromLimittedChord
(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..])
binaryAccident =
PatternPoly
selectFromLimittedChord
(EventList.fromPairList $
zip (0 : repeat 1) $
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 ::
Int -> PatternMono Int
cycleUpOctave number =
PatternMono selectFromOctaveChord (cycle [0..(number1)])
random, randomInversions :: PatternMono Double
random =
PatternMono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42))
randomInversions =
inversions $
map sum $
ListHT.sliceVertical 3 $
Rnd.randomRs (1,1) $
Rnd.mkStdGen 42
cycleUpInversions :: Int -> PatternMono Double
cycleUpInversions n =
inversions $ cycle $ take n $
map (\i -> fromInteger i / fromIntegral n) [0..]
inversions :: [Double] -> PatternMono Double
inversions rs =
PatternMono selectInversion rs
examplePatternPolyTempo0 ::
EventList.T Int [IndexNote Int]
examplePatternPolyTempo0 =
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
examplePatternPolyTempo1 ::
EventList.T Int [IndexNote Int]
examplePatternPolyTempo1 =
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
checkChannel ::
(Channel -> Bool) ->
(Event.Data -> Bool)
checkChannel p e =
case e of
Event.NoteEv _notePart note ->
p (note ^. MALSA.noteChannel)
Event.CtrlEv Event.Controller ctrl ->
p (ctrl ^. MALSA.ctrlChannel)
_ -> False
checkPitch ::
(Pitch -> Bool) ->
(Event.Data -> Bool)
checkPitch p e =
case e of
Event.NoteEv _notePart note ->
p (note ^. MALSA.notePitch)
_ -> False
checkController ::
(Controller -> Bool) ->
(Event.Data -> Bool)
checkController p e =
case e of
Event.CtrlEv Event.Controller ctrlMode ->
case ctrlMode ^. MALSA.ctrlControllerMode of
MALSA.Controller ctrl _ -> p ctrl
_ -> False
_ -> False
checkMode ::
(Mode.T -> Bool) ->
(Event.Data -> Bool)
checkMode p e =
case e of
Event.CtrlEv Event.Controller ctrlMode ->
case ctrlMode ^. MALSA.ctrlControllerMode of
MALSA.Mode mode -> p mode
_ -> False
_ -> False
checkProgram ::
(Program -> Bool) ->
(Event.Data -> Bool)
checkProgram p e =
case e of
Event.CtrlEv Event.PgmChange ctrl ->
p (ctrl ^. MALSA.ctrlProgram)
_ -> False
mergeStable ::
(NonNeg.C time) =>
EventList.T time body ->
EventList.T time body ->
EventList.T time body
mergeStable =
EventList.mergeBy (\_ _ -> True)
mergeEither ::
(NonNeg.C time) =>
EventList.T time a ->
EventList.T time b ->
EventList.T time (Either a b)
mergeEither xs ys =
mergeStable (fmap Left xs) (fmap Right ys)