{-# LANGUAGE OverloadedStrings, TypeFamilies #-}

import Music.Prelude.Standard hiding (open, play, openAndPlay)
import qualified Music.Score as Score
import Control.Concurrent.Async
import Control.Applicative
import System.Process (system)

{-    
    Arvo Pärt: Cantus in Memory of Benjamin Britten (1977)

    Inspired by the Abjad transcription
-}


main :: IO ()
main = open music

ensemble :: [Part]
ensemble = [solo tubularBells] <> (divide 2 (tutti violin)) <> [tutti viola] <> [tutti cello] <> [tutti doubleBass]

music :: Score StandardNote
music = meta $ stretch (3/2) $ {-before 60-} (mempty <> bell <> delay 6 strings)
    where
        meta = id
          . title "Cantus in Memoriam Benjamin Britten" 
          . composer "Arvo Pärt" 
          . timeSignature (6/4) 
          . tempo (metronome (1/4) 120)

withTintin :: (HasPitches' a, Score.Pitch a ~ Behavior Pitch) => Pitch -> Score a -> Score a
withTintin p x = x <> tintin p x

-- | Given the melody voice return the tintinnabular voice.
tintin :: (HasPitches' a, Score.Pitch a ~ Behavior Pitch) => Pitch -> Score a -> Score a
tintin tonic = pitches . mapped %~ relative tonic tintin'

-- | 
-- Given the melody interval (relative tonic), returns the tintinnabular voice interval. 
--
-- That is return the highest interval that is a member of the tonic minorTriad in any octave
-- which is also less than the given interval 
--
tintin' :: Interval -> Interval
tintin' melInterval 
    | isNegative melInterval = error "tintin: Negative interval"
    | otherwise = last $ takeWhile (< melInterval) $ tintinStandardNotes
    where
        tintinStandardNotes = concat $ iterate (fmap (+ _P8)) minorTriad
        minorTriad = [_P1,m3,_P5]


bell :: Score StandardNote
bell = let
    cue :: Score (Maybe StandardNote)
    cue = stretchTo 1 (rest |> a) 
    in parts' .~ (ensemble !! 0) $ text "l.v." $ mcatMaybes $ times 40 $ scat [times 3 $ scat [cue,rest], rest^*2]

strings :: Score StandardNote
strings = strings_vln1 <> strings_vln2 <> strings_vla <> strings_vc <> strings_db

strings_vln1 = clef GClef $ parts' .~ (ensemble !! 1) $ up (_P8^*1)   $ strings_cue
strings_vln2 = clef GClef $ parts' .~ (ensemble !! 2) $ up (_P8^*0)   $ stretch 2 strings_cue
strings_vla  = clef CClef $ parts' .~ (ensemble !! 3) $ down (_P8^*1) $ stretch 4 strings_cue
strings_vc   = clef FClef $ parts' .~ (ensemble !! 4) $ down (_P8^*2) $ stretch 8 strings_cue
strings_db   = clef FClef $ parts' .~ (ensemble !! 5) $ down (_P8^*3) $ stretch 16 strings_cue
strings_cue = delay (1/2) $ withTintin (down (_P8^*4) $ asPitch a) $ mainSubject

fallingScale :: [Score StandardNote]
fallingScale = [a',g'..a_]

fallingScaleSect :: Int -> [Score StandardNote]
fallingScaleSect n = {-fmap (annotate (show n)) $-} take n $ fallingScale

mainSubject :: Score StandardNote
mainSubject = stretch (1/6) $ asScore $ scat $ mapEvensOdds (accent . (^*2)) id $ concatMap fallingScaleSect [1..30]

















mapEvensOdds :: (a -> b) -> (a -> b) -> [a] -> [b]
mapEvensOdds f g xs = let
    evens = fmap (xs !!) [0,2..]
    odds = fmap (xs !!) [1,3..]
    merge xs ys = concatMap (\(x,y) -> [x,y]) $ xs `zip` ys
    in take (length xs) $ map f evens `merge` map g odds


openAudacity :: Score StandardNote -> IO ()    
openAudacity x = do
    void $ writeMidi "test.mid" $ x
    void $ system "timidity -Ow test.mid"
    void $ system "open -a Audacity test.wav"

openAudio :: Score StandardNote -> IO ()    
openAudio x = do
    -- void $ writeMidi "test.mid" $ x
    void $ system "timidity -Ow test.mid"
    void $ system "open -a Audacity test.wav"

fixClefs :: Score StandardNote -> Score StandardNote
fixClefs = id
-- fixClefs = pcat . fmap (uncurry g) . extractParts'
--     where
--         g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x

concurrently_ :: IO a -> IO b -> IO ()
concurrently_ = concurrentlyWith (\x y -> ())

concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c
concurrentlyWith f x y = uncurry f <$> x `concurrently` y

play, open, openAndPlay :: Score StandardNote -> IO ()   
tempo_ = 120
play x = openAudio $ stretch ((60*4)/tempo_) $ fixClefs $ x
open x = openLilypond' LyScoreFormat $ fixClefs $ x
openAndPlay x = play x `concurrently_` open x