content: -- Copyright 2013 Evan Laforge
  -- This program is distributed under the terms of the GNU General Public
  -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt
  
  -- | Idiomatic things for various instruments.
  module Derive.C.Post.Idiom where
  import qualified Data.List as List
  import qualified Data.Map as Map
  import qualified Data.Maybe as Maybe
  import qualified Data.Text as Text
  
  import qualified Util.Lists as Lists
  import qualified Derive.Attrs as Attrs
  import qualified Derive.C.Prelude.Note as Note
  import qualified Derive.Call.Ly as Ly
  import qualified Derive.Call.Module as Module
  import qualified Derive.Call.Post as Post
  import qualified Derive.Call.Tags as Tags
  import qualified Derive.Derive as Derive
  import qualified Derive.LEvent as LEvent
  import qualified Derive.Library as Library
  import qualified Derive.Score as Score
  import qualified Derive.ScoreT as ScoreT
  import qualified Derive.ShowVal as ShowVal
  import qualified Derive.Sig as Sig
  import qualified Derive.Stream as Stream
  
  import qualified Perform.RealTime as RealTime
  
  import           Global
  import           Types
  
  
  library :: Library.Library
  library = Library.transformers
      [ ("pizz-arp", c_pizz_arp)
      , ("avoid-overlap", c_avoid_overlap)
      , ("zero-duration-mute", c_zero_duration_mute)
      , ("extend-duration", c_extend_duration)
      , ("apply-attributes", c_apply_attributes)
      ]
  
  -- * pizz arp
  
  c_pizz_arp :: Derive.Transformer Derive.Note
  c_pizz_arp = Derive.transformer Module.prelude "pizz-arp"
      (Tags.postproc <> Tags.inst)
      "Arpeggiate simultaneous notes with `+pizz`. The order is arbitrary but\
      \ probably in track order.  TODO sort by pitch?" $
      Sig.callt (Sig.defaulted "time" (0.02 :: RealTime)
          "Insert this much time between each note."
      ) $
      \time _args deriver -> Ly.when_lilypond deriver $
          pizz_arp time =<< deriver
  
  pizz_arp :: RealTime -> Stream.Stream Score.Event -> Derive.NoteDeriver
  pizz_arp time = map_simultaneous 0.025 (Score.has_attribute Attrs.pizz) $
      \(event :| chord) -> return
          [ Score.move (+t) event
          | (t, event) <- zip (Lists.range_ 0 time) (event : chord)
          ]
  
  map_simultaneous :: RealTime
      -- ^ events starting closer than this amount are considered simultaneous
      -> (Score.Event -> Bool)
      -- ^ only process events that pass this predicate
      -> (NonEmpty Score.Event -> Derive.Deriver [Score.Event])
      -- ^ process simultaneous events
      -> Stream.Stream Score.Event -> Derive.NoteDeriver
  map_simultaneous eta accept f =
      fmap Stream.from_sorted_list . go . Stream.to_list
      where
      go [] = return []
      go (LEvent.Log log : events) = (LEvent.Log log :) <$> go events
      go (LEvent.Event event : events)
          | accept event = collect event events
          | otherwise = (LEvent.Event event :) <$> go events
      collect event events = do
          out <- f (event :| wanted)
          out_rest <- go rest
          return $ map LEvent.Event (out ++ unwanted) ++ map LEvent.Log logs
              ++ out_rest
          where
          start = Score.event_start event
          (with, rest) = span
              (LEvent.log_or ((<=start) . subtract eta . Score.event_start))
              events
          (chord, logs) = LEvent.partition with
          (wanted, unwanted) = List.partition accept chord
  
  -- * avoid overlap
  
  c_avoid_overlap :: Derive.Transformer Derive.Note
  c_avoid_overlap = Derive.transformer Module.prelude "avoid-overlap"
      (Tags.postproc <> Tags.inst)
      "Notes with the same instrument and starting pitch are shortened so they\
      \ don't overlap with each other.  This simulates keyboard instruments, \
      \ where you have to release a key before striking the same key again.\
      \ This also happens to be what MIDI expects, since it's based on keyboards."
      $ Sig.callt (Sig.defaulted "time" (0.1 :: Double)
          "Ensure at least this much time between two notes of the same pitch.")
      $ \time _args deriver -> Ly.when_lilypond deriver $
          avoid_overlap time <$> deriver
  
  avoid_overlap :: RealTime -> Stream.Stream Score.Event
      -> Stream.Stream Score.Event
  avoid_overlap time = Post.emap1_ modify . next_same_pitch
      where
      modify (event, []) = event
      modify (event, next : _)
          | overlaps event next = Score.set_duration dur event
          | otherwise = event
          where
          dur = max Note.min_duration $
              Score.event_start next - time - Score.event_start event
      overlaps event next = Score.event_end event + time > Score.event_start next
  
  -- | For each event, get the next events with the same instrument and starting
  -- pitch.
  next_same_pitch :: Stream.Stream Score.Event
      -> Stream.Stream (Score.Event, [Score.Event])
  next_same_pitch = Post.emap1_ check . Stream.zip_on Post.nexts
      where
      check (nexts, event) = (event, filter (same event) nexts)
      same event next =
          Score.event_instrument event == Score.event_instrument next
          && Maybe.isJust nn && nn == Score.initial_nn next
          where nn = Score.initial_nn event
  
  
  -- * zero dur mute
  
  -- | See DUtil.zero_duration for a version that can apply any kind of
  -- transformation.  This one is limited to attrs because it's a postproc, and
  -- it's a postproc because otherwise it's hard to tell if a note is really
  -- zero duration and not just an infer-duration note.
  c_zero_duration_mute :: Derive.Transformer Derive.Note
  c_zero_duration_mute = Derive.transformer Module.prelude
      "zero-duration-mute" (Tags.postproc <> Tags.inst)
      "Add attributes to zero duration events."
      $ Sig.callt ((,)
      <$> Sig.defaulted "attr" Attrs.mute "Add this attribute."
      <*> Sig.defaulted "dyn" (0.75 :: Double) "Scale dynamic by this amount."
      ) $ \(attrs, dyn) _args deriver -> Post.emap1_ (add attrs dyn) <$> deriver
      where
      add attrs dyn event
          | Score.event_duration event == 0 =
              Score.modify_dynamic (*dyn) $ Score.add_attributes attrs event
          | otherwise = event
  
  
  -- * extend duration
  
  c_extend_duration :: Derive.Transformer Derive.Note
  c_extend_duration = Derive.transformer Module.prelude "extend-duration"
      Tags.postproc ("Extend the duration of notes with certain attributes.\
      \ This is appropriate for attributes like " <> ShowVal.doc Attrs.staccato
      <> ", which might already have their own built-in duration, and sound\
      \ better when given as much time to ring as possible."
      ) $ Sig.callt ((,)
      <$> Sig.required "attrs" "Extend durations of notes with these attrs."
      <*> Sig.defaulted "dur" (RealTime.seconds 2)
          "Extend to a minimum of this duration."
      ) $ \(attrs, dur) _args deriver -> Ly.when_lilypond deriver $
          extend_duration attrs dur <$> deriver
  
  -- | Don't overlap with another note with the same pitch, as in 'avoid_overlap'.
  extend_duration :: [Attrs.Attributes] -> RealTime -> Stream.Stream Score.Event
      -> Stream.Stream Score.Event
  extend_duration attrs dur = Post.emap1_ extend . next_same_pitch
      where
      extend (event, nexts)
          | any (\a -> Score.has_attribute a event) attrs =
              Score.duration (max $ maybe dur (min dur) max_dur) event
          | otherwise = event
          where max_dur = diff event <$> Lists.head nexts
      diff e1 e2 = max 0 $ Score.event_start e2 - Score.event_start e1 - 0.05
  
  
  -- * apply attributes
  
  c_apply_attributes :: Derive.Transformer Derive.Note
  c_apply_attributes = Derive.transformer Module.prelude "apply-attributes"
      Tags.postproc ("Apply attributes by control signal. This looks for\
          \ controls with a " <> ShowVal.doc control_prefix <> " prefix.\
          \ A control named " <> ShowVal.doc (control_prefix <> "a-b")
  
          <> " will, when non-zero, add the `+a+b` attributes to its events."
      ) $ Sig.call0t $ \_args deriver -> Post.emap1_ apply_attributes <$> deriver
  
  -- | For all controls that start with 'control_prefix' and are positive during
  -- the event start, add those attributes to the event.
  --
  -- TODO a possible variation would be to take 0<v<1 as a probability of
  -- applying the attribute.
  apply_attributes :: Score.Event -> Score.Event
  apply_attributes event = Score.add_attributes (mconcat attrs_to_apply) event
      where
      controls :: [(Attrs.Attributes, ScoreT.Control)]
      controls = Lists.keyOnJust control_attributes $ Map.keys $
          Score.event_controls event
      attrs_to_apply = map fst $ filter ((>0) . get . snd) controls
      get c = maybe 0 ScoreT.val_of $
          Score.control_at (Score.event_start event) c event
  
  control_attributes :: ScoreT.Control -> Maybe Attrs.Attributes
  control_attributes = fmap (Attrs.attrs . Text.split (=='-'))
      . Text.stripPrefix control_prefix . ScoreT.control_name
  
  control_prefix :: Text
  control_prefix = "attr-"
  