hommage-0.0.5: Sound/Hommage/Notation.hs
module Sound.Hommage.Notation
(
-- * Duration
Dur
, absDur
, IsDur (..)
, WithDur (..)
-- * Music Notation
, Notation (..)
, runNotation
, runNotationWith
-- * Musical class
, Stretchable (..)
, Arrangeable (..)
, Musical (..)
, rest0
, (-=-)
, (->-)
, line
, line'
, chord
, proportional
-- * Notation and Midi
, writeMidiSyncNotation
, midi
, midi'
, midiSyncFile
-- * More Notation functions
, note
, mapNotation
, joinNotation
, unmaybeNotation
, durationNotation
, positionNotation
, reverseNotation
, takeNotation
, dropNotation
-- , chordNotation
-- , lineNotation
-- , lineNotation'
-- , propNotation
, filterNotation
, filterNotation'
, sequenceNotation
)
where
import Sound.Hommage.Midi
import Data.Ratio
-------------------------------------------------------------------------------
-- | The duration (of a note, e. g).
type Dur = Ratio Int
-- | Calculates the absolute duration by dividing the numerator with the denominator.
-- Because of rounding error this makes only sense if the result is a relative big
-- number.
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
-------------------------------------------------------------------------------
-- | A type\/structure that can be stretched.
class Stretchable a where
stretch :: Dur -> a -> a
-------------------------------------------------------------------------------
-- | Types\/structures that can be composed in two ways, parallel and sequent.
class Arrangeable a where
parallel :: a -> a -> a
sequent :: a -> a -> a
(-=-) :: Arrangeable a => a -> a -> a
(-=-) = parallel
(->-) :: Arrangeable a => a -> a -> a
(->-) = sequent
{-
instance Functor ((->)s) where
fmap f g = f . g
-}
-------------------------------------------------------------------------------
-- | Instances of class 'Musical' must be 'Stretchable', 'Arrangeable' and
-- they must implement the method 'rest'.
class (Stretchable a, Arrangeable a) => Musical a where
rest :: a
rest0 :: Musical a => a
rest0 = stretch 0 rest
-- | A sequence of sounds
line :: Musical a => [a] -> a
line = foldr (->-) rest0
-- | A sequence of sounds that will be stretched to length=1
line' :: Musical a => [a] -> a
line' [] = rest
line' xs = stretch (1 % length xs) $ foldr1 (->-) xs
chord :: Musical a => [a] -> a
chord = foldr (-=-) rest0
-- | Composes the notations sequentially and stretches them proportionally.
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
-------------------------------------------------------------------------------
-- | A 'Notation' is a constant, tree-like structure that represents a musical
-- notation. It has a type parameter for flexible usage reasons.
data Notation a = Note Dur a -- ^ A note with given duration and a value of type @a@.
| Rest Dur -- ^ A rest with given duration.
| Notation a :+: Notation a -- ^ Sequential composition of two notations.
| Notation a :=: Notation a -- ^ Parallel composition of two notations.
| Stretch Dur (Notation a) -- ^ Stretches the duration of the sub-music by given factor.
-- | Creates a note with length 1. Is a synonym for @Note (1%1)@
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
-------------------------------------------------------------------------------
-- | A 'Notation' can be interpreted if the contained type is an
-- instance of class 'Musical'.
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
-------------------------------------------------------------------------------
-- | 'Notation' is instance of the class Functor.
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)
-- | 'Notation' is instance of the class Monad. Joining will replace
-- every (outer) Note by its contained (inner) Notation. The inner
-- Notation will be stretched by the duration of the (outer) Note.
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)
-- | Replaces any Note that contains Nothing by a rest (with same duration).
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
-------------------------------------------------------------------------------
-- | A @ Notation MidiNote @ can be interpreted using 'runNotationWith' and 'midi'.
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))
-- | A convenient function to write a set of midi notations to a synchronous MIDI-file.
-- NOTE: For unknown reasons not any Ticks value seemes to work. This function uses
-- 96 Ticks per quarter.
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)
-------------------------------------------------------------------------------
-- | Calculates the (relative) duration of a 'Notation' (Must be finite!).
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'
-- | Calculates the offset for each note.
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'
-- | Reverses a 'Notation' (Must be finite!).
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'
-- | Takes the beginning of 'Notation', result has the given duration if possible or is shorter otherwise.
-- Notes that overlap with the end of duration are not taken but replaced by the (fitted) rests.
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 0 _ -> (Rest 0, 0)
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)
-- | Drops the beginning of 'Notation'. Notes that would be split are replaced by fitted rests.
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)
-- -- | Composes the notations sequentially.
--lineNotation :: [Notation a] -> Notation a
--lineNotation ns = foldr (:+:) (Rest 0) ns
-- -- | Composes the notations in parallel (starting at the same time).
--chordNotation :: [Notation a] -> Notation a
--chordNotation ns = foldr (:=:) (Rest 0) ns
-- | Replaces notes where the predicate fails with rests.
--filterNotation :: (a -> Bool) -> Notation a -> Notation a
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
-- -- | Composes the notations sequentially and divides the duration by the
-- -- number of notations in the list.
--lineNotation' :: [Notation a] -> Notation a
--lineNotation' ns = stretch (1 % length ns) $ lineNotation ns
-- -- | Composes the notations sequentially and stretches them proportionally.
--propNotation :: (Int, Int) -> Notation a -> Notation a -> Notation a
--propNotation (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
---------------------------------------------------------------------------------------------------
-- | A parallel composition of a sequence of values and a Notation
-- Each value of the sequence has the same given duration.
-- Every Note is updated by a function that gets the actual value of the sequence.
-- NOTE: This function is not tested yet!
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))
-- stepsize error duration error
--loop :: Ratio Int -> Ratio Int -> [a] -> Music b -> (Music c, Ratio Int, Ratio Int, [a])
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, [])
---------------------------------------------------------------------------------------------------
-- | NOTE: This function is not tested yet!
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))
-- stepsize error duration error
--loop :: Ratio Int -> Ratio Int -> [a] -> Music b -> (Music c, Ratio Int, Ratio Int, [a])
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')