module Sound.Hommage.Notation
(
Dur
, absDur
, IsDur (..)
, WithDur (..)
, Notation (..)
, runNotation
, runNotationWith
, Stretchable (..)
, Arrangeable (..)
, Musical (..)
, rest0
, (-=-)
, (->-)
, line
, line'
, chord
, proportional
, writeMidiSyncNotation
, midi
, midi'
, midiSyncFile
, note
, mapNotation
, joinNotation
, unmaybeNotation
, durationNotation
, positionNotation
, reverseNotation
, takeNotation
, dropNotation
, filterNotation
, filterNotation'
, sequenceNotation
)
where
import Sound.Hommage.Midi
import Data.Ratio
type Dur = Ratio Int
absDur :: Dur -> Int
absDur d = div (numerator d) (denominator d)
newtype IsDur d => WithDur d a = WithDur { unWithDur :: d -> a }
instance IsDur d => Stretchable (WithDur d a) where
stretch dur (WithDur f) = WithDur $ \d -> f (durUpdate (*dur) d)
instance (IsDur d, Arrangeable a) => Arrangeable (WithDur d a) where
parallel (WithDur r1) (WithDur r2) = WithDur $ \d ->
parallel (r1 d) (r2 d)
sequent (WithDur r1) (WithDur r2) = WithDur $ \d ->
sequent (r1 d) (r2 d)
instance Stretchable a => Stretchable (s -> a) where
stretch d f = stretch d . f
instance Arrangeable a => Arrangeable (s -> a) where
parallel f g = \s -> parallel (f s) (g s)
sequent f g = \s -> sequent (f s) (g s)
instance Musical a => Musical (s -> a) where
rest = const rest
class IsDur d where
durFrom :: d -> Dur
durUpdate :: (Dur -> Dur) -> d -> d
instance IsDur Dur where
durFrom = id
durUpdate f = f
class Stretchable a where
stretch :: Dur -> a -> a
class Arrangeable a where
parallel :: a -> a -> a
sequent :: a -> a -> a
(-=-) :: Arrangeable a => a -> a -> a
(-=-) = parallel
(->-) :: Arrangeable a => a -> a -> a
(->-) = sequent
class (Stretchable a, Arrangeable a) => Musical a where
rest :: a
rest0 :: Musical a => a
rest0 = stretch 0 rest
line :: Musical a => [a] -> a
line = foldr (->-) rest0
line' :: Musical a => [a] -> a
line' [] = rest
line' xs = stretch (1 % length xs) $ foldr1 (->-) xs
chord :: Musical a => [a] -> a
chord = foldr (-=-) rest0
proportional :: Musical a => (Int, Int) -> a -> a -> a
proportional (l,r) c1 c2 | l == r = stretch (1 % 2) (c1 ->- c2)
| otherwise = let l' = abs l
r' = abs r
in stretch (l' % (l'+r')) c1
->- stretch (r' % (l'+r')) c2
data Notation a = Note Dur a
| Rest Dur
| Notation a :+: Notation a
| Notation a :=: Notation a
| Stretch Dur (Notation a)
note :: a -> Notation a
note a = Note (1%1) a
instance Functor Notation where
fmap = mapNotation
instance Stretchable (Notation a) where
stretch = Stretch
instance Arrangeable (Notation a) where
sequent = (:+:)
parallel = (:=:)
instance Musical (Notation a) where
rest = Rest (1%1)
instance Monad Notation where
return a = Note (1%1) a
na >>= f = joinNotation $ fmap f na
runNotation :: Musical m => Notation m -> m
runNotation = loop
where
loop m = case m of
Note d a -> stretch d a
Rest d -> stretch d rest
m1 :+: m2 -> loop m1 `sequent` loop m2
m1 :=: m2 -> loop m1 `parallel` loop m2
Stretch d m1 -> stretch d $ loop m1
runNotationWith :: Musical m => (a -> m) -> Notation a -> m
runNotationWith note = loop
where
loop m = case m of
Note d a -> stretch d $ note a
Rest d -> stretch d rest
m1 :+: m2 -> loop m1 `sequent` loop m2
m1 :=: m2 -> loop m1 `parallel` loop m2
Stretch d m1 -> stretch d $ loop m1
mapNotation :: (a -> b) -> Notation a -> Notation b
mapNotation f m = case m of
Note d a -> Note d (f a)
Rest d -> Rest d
m1 :+: m2 -> mapNotation f m1 :+: mapNotation f m2
m1 :=: m2 -> mapNotation f m1 :=: mapNotation f m2
Stretch d m1 -> Stretch d (mapNotation f m1)
joinNotation :: Notation (Notation a) -> Notation a
joinNotation m = case m of
Note d a -> Stretch d a
Rest d -> Rest d
m1 :+: m2 -> joinNotation m1 :+: joinNotation m2
m1 :=: m2 -> joinNotation m1 :=: joinNotation m2
Stretch d m1 -> Stretch d (joinNotation m1)
unmaybeNotation :: Notation (Maybe a) -> Notation a
unmaybeNotation = loop
where
loop m = case m of
Note d (Just a) -> Note d a
Note d _ -> Rest d
Rest d -> Rest d
m1 :+: m2 -> loop m1 :+: loop m2
m1 :=: m2 -> loop m1 :=: loop m2
Stretch d m1 -> Stretch d $ loop m1
midi :: IsDur d => MidiNote -> WithDur d MidiMusic
midi n = WithDur $ \d -> noteMidiMusic (fromIntegral $ absDur $ durFrom d) n
midi' :: IsDur d => WithDur d MidiNote -> WithDur d MidiMusic
midi' rn = WithDur $ \d -> unWithDur (midi $ unWithDur rn d) d
midiSyncFile :: Ticks -> [WithDur Dur MidiMusic] -> MidiFile
midiSyncFile ticks =
let dur = ((4 * fromIntegral ticks) % 1)
in MidiSync ticks . map (runMidiMusic . (flip unWithDur dur))
writeMidiSyncNotation :: FilePath -> [Notation MidiNote] -> IO ()
writeMidiSyncNotation fp = writeMidiFile fp . midiSyncFile 96 . map (runNotationWith midi)
instance Arrangeable MidiMusic where
parallel = mergeMidiMusic
sequent = appendMidiMusic
instance IsDur d => Musical (WithDur d MidiMusic) where
rest = WithDur $ \d -> restMidiMusic (fromIntegral $ absDur $ durFrom d)
durationNotation :: Notation a -> Ratio Int
durationNotation m =
case m of
Note d a -> d
Rest d -> d
m1 :+: m2 -> durationNotation m1 + durationNotation m2
m1 :=: m2 -> durationNotation m1 `max` durationNotation m2
Stretch r m' -> r * durationNotation m'
positionNotation :: Notation a -> Notation (Dur, a)
positionNotation = fst . loop 1 0
where
loop l p m = case m of
Note d a -> let d' = (d*l) in (Note d' (p, a), p+d')
Rest d -> let d' = (d*l) in (Rest d', p+d')
m1 :+: m2 -> let (m1', p1) = loop l p m1
(m2', p2) = loop l p1 m2
in (m1' :+: m2', p2)
m1 :=: m2 -> let (m1', p1) = loop l p m1
(m2', p2) = loop l p m2
in (m1' :=: m2', max p1 p2)
Stretch r m' -> loop (r*l) p m'
reverseNotation :: Notation a -> Notation a
reverseNotation m =
case m of
Note d a -> m
Rest d -> m
m1 :+: m2 -> reverseNotation m2 :+: reverseNotation m1
m1 :=: m2 -> let d1 = durationNotation m1
d2 = durationNotation m2
re | d1 < d2 = (Rest (d2 d1) :+: reverseNotation m1) :=: reverseNotation m2
| d1 > d2 = reverseNotation m1 :=: (Rest (d1 d2) :+: reverseNotation m2)
| otherwise = reverseNotation m1 :=: reverseNotation m2
in re
Stretch r m' -> Stretch r $ reverseNotation m'
takeNotation :: Ratio Int -> Notation a -> Notation a
takeNotation len mus = fst $ take len mus
where
take :: Ratio Int -> Notation a -> (Notation a, Ratio Int)
take r m = if r <= 0 % 1 then (Rest (0%1), 0%1) else
case m of
Note d a | d > r -> (Rest r, 0%1)
| otherwise -> (Note d a, r d)
Rest d | d > r -> (Rest r, 0%1)
| otherwise -> (Rest d, r d)
m1 :+: m2 -> let (rm1,r1) = take r m1
(rm2,r2) = take r1 m2
in if r1 > 0%1 then (rm1 :+: rm2, r2) else (rm1, r1)
m1 :=: m2 -> let (rm1,r1) = take r m1
(rm2,r2) = take r m2
in (rm1 :=: rm2, min r1 r2)
Stretch d m' -> let (mu,le) = take (r / d) m' in (Stretch d mu, le)
takeline r [] = ([], r)
takeline r (u:us) =
if r > 0%1
then let (u',ur) = take r u
(ul,rr) = takeline ur us
in if ur > 0%1 then (u':ul,rr) else ([u'],0%1)
else ([], 0%1)
dropNotation :: Ratio Int -> Notation a -> Notation a
dropNotation len mus = either id (const $ Rest (0%1)) $ drop len mus
where
drop :: Ratio Int -> Notation a -> Either (Notation a) (Ratio Int)
drop r m = if r <= 0 % 1 then Left m else
case m of
Note d a | d > r -> Left $ Rest (d r)
| otherwise -> Right (r d)
Rest d | d > r -> Left $ Rest (d r)
| otherwise -> Right (r d)
m1 :+: m2 -> case drop r m1 of
Left m1' -> Left (m1' :+: m2)
Right r' -> drop r' m2
m1 :=: m2 -> case (drop r m1, drop r m2) of
(Left m1', Left m2') -> Left (m1' :=: m2')
(Left m1', _ ) -> Left m1'
(_' , Left m2') -> Left m2'
(Right r1, Right r2) -> Right (min r1 r2)
Stretch d m' -> either (Left . Stretch d) Right $ drop (r / d) m'
dropline r [] = Right r
dropline r (u:us) =
if r > 0%1
then case drop r u of
Left u' -> Left (u' : us)
Right r' -> dropline r' us
else Left (u:us)
filterNotation :: (Musical (m a), Monad m) => (a -> Bool) -> m a -> m a
filterNotation p n = n >>= \a -> if p a then return a else rest
filterNotation' :: (Musical (m a), Musical (m b), Monad m) => (a -> Maybe b) -> m a -> m b
filterNotation' f n = n >>= maybe rest return . f
sequenceNotation :: (a -> b -> c) -> Dur -> [a] -> Notation b -> Notation c
sequenceNotation f stpsz input mub = let (x,_,_,_) = loop (denominator stpsz % numerator stpsz) (0%1) input mub in x
where
step x = let i = div (numerator x) (denominator x)
in (i, x (i % 1))
loop stepsize off as@(a:_) mu =
case mu of
Note d b -> let (i,off') = step (off + stepsize * d)
in (Note d (f a b), d, off', drop i as)
Rest d -> let (i,off') = step (off + stepsize * d)
in (Rest d, d, off', drop i as)
m1 :+: m2 -> let (m1', d1, o1, as1) = loop stepsize off as m1
(m2', d2, o2, as2) = loop stepsize o1 as1 m2
in (m1' :+: m2', d1 + d2, o2, as2)
m1 :=: m2 -> let (m1', d1, o1, as1) = loop stepsize off as1 m1
(m2', d2, o2, as2) = loop stepsize off as2 m2
(d', o', as') | d1 < d2 = (d2, o2, as2)
| d1 > d2 = (d1, o1, as1)
| o1 < o2 = (d2, o2, as2)
| otherwise = (d1, o1, as1)
in (m1' :=: m2', d', o', as')
Stretch r m -> let (m', d', o', as') = loop (stepsize * r) off as m
in (Stretch r m', d', o', as')
loop stepsize off [] mu = (Rest (0%1), 0%1, 0%1, [])
sequenceNotations :: (a -> b -> c) -> Dur -> [a] -> [Notation b] -> [Notation c]
sequenceNotations f stpsz input mubs = let (x,_,_,_) = aux (denominator stpsz % numerator stpsz) (0%1) input mubs in x
where
step x = let i = div (numerator x) (denominator x)
in (i, x (i % 1))
loop stepsize off as@(a:_) mu =
case mu of
Note d b -> let (i,off') = step (off + stepsize * d)
in (Note d (f a b), d, off', drop i as)
Rest d -> let (i,off') = step (off + stepsize * d)
in (Rest d, d, off', drop i as)
m1 :+: m2 -> let (m1', d1, o1, as1) = loop stepsize off as m1
(m2', d2, o2, as2) = loop stepsize o1 as1 m2
in (m1' :+: m2', d1 + d2, o2, as2)
m1 :=: m2 -> let (m1', d1, o1, as1) = loop stepsize off as1 m1
(m2', d2, o2, as2) = loop stepsize off as2 m2
(d', o', as') | d1 < d2 = (d2, o2, as2)
| d1 > d2 = (d1, o1, as1)
| o1 < o2 = (d2, o2, as2)
| otherwise = (d1, o1, as1)
in (m1' :=: m2', d', o', as')
Stretch r m -> let (m', d', o', as') = loop (stepsize * r) off as m
in (Stretch r m', d', o', as')
loop stepsize off [] mu = (Rest (0%1), 0%1, 0%1, [])
aux stepsize off as@(a:_) ms =
let fu o as [] = ([] ,0%1,o,as)
fu o as (m:ms) = let (m' ,d,o',as') = loop stepsize o as m
(ms',ds,o'',as'') = fu o' as' ms
in (m':ms', d+ds, o'', as'')
(ms',d,off',as') = fu off as ms
in (ms', d, off', as')