music-preludes-1.8.1: examples/imitations.hs
{-# LANGUAGE NoMonomorphismRestriction #-}
module Main where
import Music.Time.Internal.Util (rotate)
import Music.Prelude
import qualified Data.Ratio
-- Get (bar,beat)
-- 400 bars in 60 BPM
-- 20 seconds in bar 401
-- 45 bars (to 446)
-- 30 seconds in bar 447
-- notePos :: Int -> (Int,Int)
-- notePos t | t < 1600 = ( t `div` 4 + 1 , t `mod` 4 + 1)
-- | 1600 <= t && t < 1620 = ( 401 , t - (400*4) + 1)
-- | 400*4+20 <= t && t < 445*4+20 = ( (t-20) `div` 4 + 2, (t-20) `mod` 4 + 1 )
-- | otherwise = 447
main = {-openMusicXml-}open noteScore
noteScore :: Score StandardNote
noteScore = compress 4 $ {-addInstrChange $-}
mempty
-- * Part 1 (first canon and col legno)
||> (colLegno1 </> delay (4*3) colLegno1)
-- ||> (canon_I <> (delay (4*5) $ moveToPart vl2 $ canon_I)) -- A
||> (colLegno2 </> delay (4*3) colLegno2) -- B
--
-- -- * Part 2 (canon_II and surrounding)
-- -- C
-- ||> (level _p $ bar^*30
-- <> delay 0 (moveToPart vc2 g_^*(4*13))
-- <> delay (4*15) (moveToPart vc1 a_^*(4*13))
-- )
-- -- -- D, E
-- ||> canon_II
-- ||> (bar^*15 <> moveToPart vl2 (rev canon_II))
-- -- -- F
-- ||> (level _p $ bar^*30
-- <> delay 0 (moveToPart vc2 bb_^*(4*15))
-- <> delay (4*15) (moveToPart vc1 c ^*(4*15))
-- )
-- ||> (canon_III <> (delay (4*30) $ moveToPart vl2 $ canon_III)) -- A
--
--
-- -- * Part 3 (development to canon_IV)
-- -- I
-- ||> (mempty
-- <> delay 0 (moveToPart vl1 f' ^*(4*15))
-- <> delay (4*15) (moveToPart vl2 f' ^*(4*15))
-- )
-- -- K
-- ||> bar^*1
-- ||> canon_IV
--
-- ||> rest^*20
--
-- -- * Part 4 (jete)
-- -- FIXME sync back to score
-- ||> mconcat [
-- delay 0 $ level ppp $ up (12*3) $ moveToPart vl2 $ d_^*(4*30),
-- delay (4*10) (level _p $ jete1 </> delay (12*8) jete1)
-- ]
-- ||> bar^*2
-- ||> c'^*4 -- mark ending!
(||>) = (|>)
--------------------------------------------------------------------------------
colLegno1 :: Score StandardNote
colLegno1 = {-staccato $ -} level (ppp {-`cresc` mp |> mp^*0.2-}) $ text "col legno battuto" $
(down _P8 $ delay 0 $ repTimes 7 $ removeRests $ ([4,4,4,5,4] `groupWith` g) |> rest^*6)
</> (down _P8 $ delay 1 $ repTimes 7 $ removeRests $ ([4,4,5,4,5] `groupWith` g) |> rest^*6)
</> (down _P15 $ delay 3 $ repTimes 7 $ removeRests $ ([4,5,4,5,4] `groupWith` g) |> rest^*6)
</> (down _P15 $ delay 6 $ repTimes 7 $ removeRests $ ([3,3,5,3,5] `groupWith` g) |> rest^*6)
-- dur 45
colLegno2 :: Score StandardNote
colLegno2 = {-staccato $ -} level (mp) $ text "col legno battuto" $
(down _P8 $ delay 0 $ repTimes 4 $ removeRests $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)
</> (down _P8 $ delay 1 $ repTimes 4 $ removeRests $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)
</> (down _P8 $ delay 3 $ repTimes 4 $ removeRests $ [4,5,4,5,4,4] `groupWith` g |> rest^*6)
</> (down _P8 $ delay 6 $ repTimes 4 $ removeRests $ [3,3,5,3,3] `groupWith` g |> rest^*6)
--
colLegno2Alt :: Score StandardNote
colLegno2Alt = {-staccato $ -} level (mp) $ text "col legno battuto" $
(down _P8 $ delay 0 $ removeRests $ repWithIndex 4 $ \t -> [4,4,5,4,5,4] `groupWith` g |> rest^*(1+4*t))
</> (down _P8 $ delay 1 $ removeRests $ repWithIndex 4 $ \t -> [4,4,5,4,5,4] `groupWith` g |> rest^*(1+4*t))
</> (down _P15 $ delay 3 $ removeRests $ repWithIndex 4 $ \t -> [4,5,4,5,4,4] `groupWith` g |> rest^*(1+4*t))
</> (down _P15 $ delay 6 $ removeRests $ repWithIndex 4 $ \t -> [3,3,5,3,3] `groupWith` g |> rest^*(1+4*t))
-- --------------------------------------------------------------------------------
--
makeJete :: Behavior Interval -> Bool -> Duration -> Score (Maybe StandardNote)
makeJete p v d = {-text "jeté" $-} pitches' %~ (.+^ p) $ removeRests $ g_ |> ((if v then cs else cs_){-^/2-}) {-|> rest^/2-} |> rest^*d
makeJetes :: [Behavior Interval] -> [Bool] -> [Duration] -> Score (Maybe StandardNote)
makeJetes ps vs ds = scat $ zipWith3 makeJete ps vs ds
jete1 :: Score StandardNote
jete1 = removeRests $ -- FIXME temporary fix w.r.t onset/padToBar
(delay 3 $ up _P1 $ makeJetes (rotate 0 ps) (rotate 3 vs) (rotate 1 ds))
</> (delay 5 $ up _P1 $ makeJetes (rotate 1 ps) (rotate 0 vs) (rotate 3 ds))^*(4/5)
</> (delay 7 $ down _P8 $ makeJetes (rotate 2 ps) (rotate 1 vs) (rotate 2 ds))
</> (delay 12 $ down _P8 $ makeJetes (rotate 3 ps) (rotate 2 vs) (rotate 0 ds))^*(4/5)
where
ps = take n $ cycle [_P1,d5,d5,_P1,d5,d5,_P1]
vs = take n $ cycle [True,False,True,False,True,False,True,False]
ds = take n $ cycle $ fmap (+ 4) [3,7,5,7,5,5,3,7,7,7,7,7,5,3,7,7,7,7,7,3,3,5]
n = 9
--
-- -- colLegno3 :: Score StandardNote
-- -- colLegno3 = (down _P8 $ delay 0 $ rep $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)
--
--
-- --------------------------------------------------------------------------------
--
makeCanon_I :: Rational -> Dynamic StandardNote -> Score StandardNote -> Score StandardNote -> Score StandardNote
makeCanon_I n dn subj1 subj2 =
level dn (empty |> (a </> b </> c </> d))
where
a = (repTimes (floor $ 5*n/(4/3)) $ subj1 ^*(4/3))
b = (repTimes (floor $ 5*n/1) $ subj2 ^*1)
c = (repTimes (floor $ 5*n/2) $ subj1 ^*2)
d = (repTimes (floor $ 5*n/3) $ subj2 ^*3)
--
canon_I :: Score StandardNote
canon_I = text "ord" $ (^*2) $ makeCanon_I 1 {-dn-}mf subj1 subj2
where
subj1 = g_ |> a_^*(3/2) |> g_^*2
subj2 = f_^*3 |> bb_^*1 |> a_ |> g_^*3
-- dn = (repTimes 5 $ (pp `cresc` mf)^*3 |> (mf `dim` pp)^*3 )
makeCanon_II :: Dynamic StandardNote -> Score StandardNote -> Score StandardNote -> Score StandardNote
makeCanon_II dn subj1 subj2 =
level dn (rev $ a </> b </> c </> d)
where
a = (repWithTime 5 $ \t -> {-up (round $ octave * t) $ -}subj1 ^*(4/3))
b = (repWithTime 5 $ \t -> {-up (round $ octave * t) $ -}subj2 ^*1)
c = (repWithTime 2 $ \t -> {-up (round $ octave * t) $ -}subj1 ^*2)
d = (repWithTime 2 $ \t -> {-up (round $ octave * t) $ -}subj2 ^*3)
repWithTime n f = scat $ fmap f [1..n]
canon_II :: Score StandardNote
canon_II = text "ord" $ (^*2) $ makeCanon_II {-dn-}mf subj1 subj2
where
subj1 = g_ |> d^*(3/2) |> c^/2 |> a_^/2 |> bb_^/2
subj2 = f_^*3 |> bb_^*1 |> a_ |> d_^*3
-- dn = (repTimes 5 $ (pp `cresc` mf)^*3 |> (mf `dim` pp)^*3 )
--
-- makeCanon_III :: Double -> Score (Levels Double) -> Score StandardNote -> Score StandardNote -> Score StandardNote
-- makeCanon_III n dn subj1 subj2 =
-- level dn (rev (a </> b </> c </> d) |> (a </> b </> c </> d))
-- where
-- a = (repTimes (5*n/(4/3)) $ subj1 ^*(4/3))
-- b = (repTimes (5*n/1) $ subj2 ^*1)
-- c = (repTimes (5*n/2) $ subj1 ^*2)
-- d = (repTimes (5*n/3) $ subj2 ^*3)
--
-- canon_III :: Score StandardNote
-- canon_III = text "ord" $ makeCanon_III 1.6 dn subj1 subj2
-- where
-- subj1 = g^*2 |> d |> eb^*(3/2) |> c^*2 |> d^*2
-- subj2 = f_^*3 |> bb_^*1 |> a_ |> g_^*2 |> d^*3 |> c^*1
-- dn = (repTimes 5 $ (mf `cresc` _f)^*3 |> (_f `dim` mf)^*3 )
--
makeCanon_IV :: Bool -> Score StandardNote -> Score StandardNote -> Score StandardNote -> Score StandardNote
makeCanon_IV flip subj1 subj2 bass = if flip then lower </> upper else upper </> lower
where
upper = (repWithTime (10/(4/5)) $ \t -> reg "Vl1" t $ subj1 ^* (4/5) )
</> (repWithTime (12/(2/3)) $ \t -> reg "Vla1" t $ subj1 ^* (2/3) )
</> (repWithTime (15/ 1 ) $ \t -> reg "Vc1" t $ subj1 ^* 1 )
</> (repWithTime (18/ 2 ) $ \t -> reg "Db2" t $ bass ^* 1 )
lower = (repWithTime (10/(2/3)) $ \t -> reg "Vl2" t $ subj2 ^* (2/3) )
</> (repWithTime (12/ 1 ) $ \t -> reg "Vla2" t $ subj2 ^* 1 )
</> (repWithTime (15/(3/2)) $ \t -> reg "Vc2" t $ subj2 ^* (3/2) )
</> (repWithTime (18/ 2 ) $ \t -> reg "Db2" t $ bass ^* 1 )
reg "Vl1" t | t < 0.3 = up (_P8 + _P5) | t < 0.6 = up _P8 | t >= 0.6 = up _P5
reg "Vl2" t | t < 0.4 = up _P8 | t < 0.7 = up _P5 | t >= 0.7 = up _P5
reg "Vla1" t | t < 0.4 = up _P5 | t < 0.7 = up _P5 | t >= 0.7 = up _P1
reg "Vla2" t | t < 0.4 = up _P1 | t < 0.7 = up _P5 | t >= 0.7 = up _P1
reg "Vc1" t | t < 0.4 = down _P8 | t < 0.7 = down _P8 | t >= 0.7 = down _P4
reg "Vc2" t | t < 0.4 = down _P8 | t < 0.7 = down _P8 | t >= 0.7 = down _P4
reg "Db1" t | t < 0.4 = down (_P8^*1) | t < 0.7 = down (_P8^*1) | t >= 0.7 = down (_P8^*1)
reg "Db2" t | t < 0.4 = down (_P8^*2) | t < 0.7 = down (_P8^*1) | t >= 0.7 = down (_P8^*1)
canon_IV :: Score StandardNote
canon_IV = text "ord" $ {-c^*padC |> firstC |>-} secondC
where
firstC = {-level dn1 $-} rev $ makeCanon_IV False subj1 subj2 bass
secondC = {-level dn2 $-} makeCanon_IV True subj1 subj2 bass
padC = fromIntegral $ 4 - Data.Ratio.numerator (realToFrac $ _duration firstC) `mod` 4
-- dn1 = (repTimes 10 $ (mf `cresc` _f)^*5 |> (_f `dim` mf)^*5)
-- dn2 = (repTimes 10 $ (_f `cresc` ff)^*5 |> (ff `dim` _f)^*5)
subj1 = down _M2 $ (d^*3 |> a |> g^*2 |> c' |> b |> c' |> b |> g |> a^*3)
subj2 = down _M2 $ (d^*2 |> a |> g^*2 |> c' |> b |> c' |> b |> g |> a^*3)
bass = scat [d,a] |> g^*2 |> scat [c,d,a] |> g^*2
-- bass = scat [d,g] |> a^*2 |> scat [c,g,d] |> a^*2
instance Reversible (Score a) where
rev = stretchRelativeMidpoint (-1)
cresc = const
dim = const
repTimes = times
-- groupWith :: [Int] -> a -> a
groupWith xs p = scat $ fmap (\n -> group n p) xs
group n x = times n x^/(fromIntegral n)
repWithIndex n f = scat $ fmap f [1..n]
moveToPart p x = parts' .~ p $ x
[vl1, vl2] = divide 2 $ tutti violin
_solo :: Lens' Part Solo
_solo f (Part s i u) = fmap (\s -> Part s i u) $ f s
_subpart :: Lens' Part Subpart
_subpart f (Part s i u) = fmap (\u -> Part s i u) $ f u
_instrument :: Lens' Part Instrument
_instrument f (Part s i u) = fmap (\i -> Part s i u) $ f i
-- Not perfect but works for many cases
ucat xs = if allDistinct ps
then mconcat xs
else mconcat $ zipWith (set parts') (divide (length xs) p) xs
where
ps = concatMap (toListOf parts') xs
p = foldr1 smallestPart ps