\version "2.18.0"
% \pointAndClickOn

% by ArnoldTheresius
% based on (and therfore thanks to Neil):
% http://old.nabble.com/Nice-workaround-for-simultaneous-rehearsal-marks-%E2%80%93-thanks-Neil!-td32212763.html
% which was defined by Neil Puttock
%{
  build an alternate \mark command and Mark_engraver
  additional options to the new variant of \mark:
    \polyMark symb text
    \polyMark #'(symb opt ...) text
      text: as is in \mark, the text or \default
      symb: optional a 'key symbol'
      opt: optional pairs for options, generally GROB overrides
    - parser does not allow \mark \default #'A ..., because
      \default = #'() = argument list ends parsing, and an optional
      argument before the label does not work well and easy, too.
  Enhanced Mark_engraver functionality:
    only accept the first Rehearsal Mark
      per key symbol
      within one main time period
    anchor new Rehearsal Mark GROBs at the first GraceTime seen in the
     (hopefully Score) context, even if the event occurs later in the same
     main time period.
     This functionality may be turned off by setting the new context property
     propagateIntoPast = ##f
  Special 'key symbols' have special GROB overrides build in, e.g.:
    #'RightUp = right aligned text, begin-of-line-invisible, direction = #UP
    #'CenterDown = center aligned text, direction = #DOWN
  Benefit:
    + allows multiple Rehearsal Marks at one Moment, even with different
      settings (grob properties)
    + but filters out the duplicates (from different parts / staves),
      identified by the key
    + eliminates the 'grace echo'
    + places Rehersal Marks at the bar line, even if they are defined 'late',
      i.e. in a control voice without grace skips.
  Caveats:
    - If one mark command sets the current mark number while another polyMark
      command displays the current mark number, the sequence they are evaluated
      defines the result.
    - No input data checks, e.g. no warning, if different values to set are
      defined.
    - creates an extra RehearsalMark to obtain a BreakAlignment, even if the
      BreakAlignment is (finally) never used.
    - Expect problems when put into Staff context. Perhaps the BreakAlignment
      grob should be caught with an extra engraver in Score context, while
      this polymark engraver will then work in Staff context.

  A more reliable method to create 'early grobs' would be welcome, maybe
  ly:engraver-make-early-grob and ly:engraver-announce-early-end-grob.

GLOSSARY:
main time period = all translation timesteps with the same main time, i.e. all
                   timesteps of grace notes offset until the final timestep
                   without grace note offset, incl.
early grob       = a grob created by an engraver at a timestep later than the
                   first grace note timestep (of the same main time) in the score,
                   but the grob has to be adjusted to the column of tis first
                   grace note timestep.

%}

#(define (add-translator-property-description symbol type? description)
  (if (not (and
	    (symbol? symbol)
	    (procedure? type?)
	    (string? description)))
      (throw 'init-format-error))
	   
       
  (if (not (equal? #f (object-property symbol 'translation-doc)))
      (ly:error (_ "symbol ~S redefined" symbol)))
  
  (set-object-property! symbol 'translation-type? type?)
  (set-object-property! symbol 'translation-doc description)
  (if (not (defined? 'all-user-translation-properties))
   (define-public all-user-translation-properties '()))
  (set! all-user-translation-properties (cons symbol all-user-translation-properties)))

#(add-translator-property-description
  'propagateIntoPast
  boolean?
  "Engravers may anchor the GROBs they create at a PaperColumn of
an already gone timestep, usually the first grace note timestep of
the same main moment.")

#(add-translator-property-description
  'inhibitDummyRehearsalMark
  boolean?
  "If true, do not create a zero size RehearsalMark in advance, just to
obtain a BreakAlignment which may be needed later in the process.
If you only need to purge 'grace echos' of RehearsalMarks but do not need
to 'shift' any RehearsalMark before the grace notes, you may want to set
this option to reduce memory consumption.")
% I could not detect a significant memory saving!

#(add-translator-property-description
  'RehearsalMarkVisibleAtEndOfContext
  boolean?
  "If true, then set the visibility of those RehearsalMarks, which are
placed at the end of the context, to end-of-line-visible.")

#(add-translator-property-description
  'RehearsalMarkPriorityRenumbering
  boolean?
  "If true, then renumber the priority of the RehearsalMarks created
at one timestep.")

#(add-translator-property-description
  'polyMarkOptions
  list?
  "Default options for user defined keys of RehearsalMarks")



#(define (poly-mark-engraver ctx)
   (define default-option-lists
    `((RightUp       (direction        . ,UP)
                     (self-alignment-X . 1)
                     (break-visibility . ,begin-of-line-invisible))
      (RightDown     (direction        . ,DOWN)
                     (self-alignment-X . 1)
                     (break-visibility . ,begin-of-line-invisible))
      (Right         (self-alignment-X . 1)
                     (break-visibility . ,begin-of-line-invisible))
      (CenterEndUp   (direction        . ,UP)
                     (self-alignment-X . 0)
                     (break-visibility . ,begin-of-line-invisible))
      (CenterEndDown (direction        . ,DOWN)
                     (self-alignment-X . 0)
                     (break-visibility . ,begin-of-line-invisible))
      (CenterEnd     (self-alignment-X . 0)
                     (break-visibility . ,begin-of-line-invisible))
      (LeftUp        (direction        . ,UP)
                     (self-alignment-X . -1)
                     (break-visibility . ,end-of-line-invisible))
      (LeftDown      (direction        . ,DOWN)
                     (self-alignment-X . -1)
                     (break-visibility . ,end-of-line-invisible))
      (Left          (self-alignment-X . -1)
                     (break-visibility . ,end-of-line-invisible))
      (CenterUp      (direction        . ,UP)
                     (self-alignment-X . 0))
      (CenterDown    (direction        . ,DOWN)
                     (self-alignment-X . 0))
      (Center        (self-alignment-X . 0))))
       
   (let ((texts '())             ;; the created Rehearsal Mark GROBs,
                                 ;; collected during a time step
         (late-texts '())        ;; the Rehearsal Mark GROBs created later than at the
                                 ;; first timestep of this main time period - we need to
                                 ;; modify their X anchor
         (final-texts '())       ;; the created GROBs after they're completed at
                                 ;; 'stop-translation-timestep', used to make them visible
                                 ;; at the end of line, if the context terminates there.
         (helper-text '())       ;; a null-markup Rehearsal Mark GROB. Only created to obtain
                                 ;; the related BreakAlignment GROB.
         (events '())            ;; list of MarkEvents, collected during a time step
         (last-main-mom '())     ;; the value of the last main time moment seen
         (late #f)               ;; true if this time step is NOT the first one of the
                                 ;; current main time period
         (keys '())              ;; list of 'entry keys' of them a grob is already created
                                 ;; during the current main time period
         (first-grace-now #f)    ;; is this the first grace time step in the current main
                                 ;; time period?
         (b-a-g '())             ;; the 'early' breakAlignment GROB, in case we need it
                                 ;; to modify the RehearsalMarks X anchor
         (priority-index 0)      ;; used to renumber the outside staff priority
         (label-incremented #f)) ;; is the ctx prop 'rehearsalMark allready incremented
                                 ;; during the current main time period?

     `((start-translation-timestep
        . ,(lambda (trans)
             (let* ((current-mom (ly:context-current-moment ctx))
                    (main-mom (ly:moment-main current-mom))
                    (grace-mom (ly:moment-grace current-mom)))
              (if (or (null? last-main-mom) (> main-mom last-main-mom))
                (begin
                  (set! last-main-mom main-mom)
                  (set! keys '())
                  (set! priority-index 0)
                  (set! label-incremented #f)
                  (set! late #f)
                  (set! first-grace-now (not (or late (= 0 grace-mom)))))
                (begin
                  (set! late #t)
                  (set! first-grace-now #f))))
              (set! final-texts '())))

       (listeners
        (mark-event
         . ,(lambda (trans ev)
              (set! events (cons ev events)))))

       (acknowledgers
        (break-alignment-interface
         . ,(lambda (trans grob source)
              ;;; (for-each display (list "\n break-alignment-interface acknowledged while having "
              ;;;   (length texts) " RehearsalMark GROB(s) "))
              (if first-grace-now (set! b-a-g grob))
              (for-each (lambda (mark)
                  (set! (ly:grob-parent mark X) grob))
                texts))))

       (process-music
        . ,(lambda (trans)
             ;;; (for-each display (list "\n " (ly:context-current-moment ctx)
             ;;;    (if first-grace-now " first-grace-now" "")
             ;;;    (if late " late" "")
             ;;;    (if (null? b-a-g) "" " b-a-g")
             ;;;    (if (null? c-c-c) "" " c-c-c")
             ;;;    " START process-music\n"))
             (for-each
               (lambda (ev)
                 (let* ((key (ly:event-property ev 'key #t))
                        (opts (ly:event-property ev 'additional-options '())))
                   (if (not (memq key keys))
                     (let* ((mark-grob
                              (ly:engraver-make-grob trans 'RehearsalMark ev))
                            (label (ly:event-property ev 'label))
                            (formatter (ly:context-property ctx 'markFormatter)))

                       (set! keys (cons key keys))

                       (if (and (procedure? formatter)
                                (not (markup? label)))
                         (begin
                           (if (not (number? label))
                             (if label-incremented
                               (set! label
                                 (1- (ly:context-property ctx 'rehearsalMark)))
                               (set! label
                                 (ly:context-property ctx 'rehearsalMark))))

                           (if (and (integer? label)
                                    (exact? label)
                                    (not label-incremented))
                             (begin
                               (set! (ly:context-property ctx 'rehearsalMark)
                                     (1+ label))
                               (set! label-incremented #t)))

                           (if (number? label)
                             (set! label (apply formatter (list label ctx)))
                             (ly:warning "rehearsalMark must have integer value"))))

                       (if (markup? label)
                         (begin
                           (set! (ly:grob-property mark-grob 'text) label)
                           (let ((dir (ly:event-property ev 'direction)))
                             (and (ly:dir? dir)
                                (set! (ly:grob-property mark-grob 'direction)
                                    dir))))
                               (ly:warning "mark label must be a markup object"))

                       (let ((both-dirs #f)
                             (predef-opts (or
                               (ly:assoc-get key (ly:context-property ctx 'polyMarkOptions) #f)
                               (ly:assoc-get key default-option-lists #f))))
                        (if (pair? predef-opts) (for-each (lambda (opt)
                           (let ((opt-name (car opt))
                                 (opt-val (cdr opt)))
                            (if (and (eq? opt-name 'direction)
                                     (eq? opt-val 'both)) (begin
                              (ly:grob-set-property! mark-grob opt-name UP)
                              (set! both-dirs #t)
                             )
                             (ly:grob-set-property! mark-grob opt-name opt-val))
                          )) predef-opts
                        ))
                        (if both-dirs
                         (let ((opposite-mark-grob
                                (ly:engraver-make-grob trans 'RehearsalMark ev)))
                          (ly:grob-set-property! opposite-mark-grob 'direction DOWN)
                          (ly:grob-set-property! opposite-mark-grob 'text
                           (ly:grob-property mark-grob 'text))
                          (set! texts (cons opposite-mark-grob texts))
                          (if (pair? predef-opts) (for-each (lambda (opt)
                             (let ((opt-name (car opt))
                                   (opt-val (cdr opt)))
                              (if (not (eq? opt-name 'direction))
                               (ly:grob-set-property! opposite-mark-grob opt-name opt-val))
                          )) predef-opts
                        ))
                          (if (and late
                                   (ly:context-property ctx 'propagateIntoPast #t))
                           (set! late-texts (cons opposite-mark-grob late-texts))))))

                       ; if 'direction == 'double, then apply these `options on the fly`
                       ; only to the UP instance
                       (if (pair? opts)
                         (for-each (lambda (opt)
                             (if (pair? opt)
                               (let ((opt-name (car opt))
                                     (opt-val (cdr opt)))
                                 (ly:grob-set-property! mark-grob opt-name opt-val)
                           ))) opts))

                       (set! texts (cons mark-grob texts))
                       (if (and late
                                (ly:context-property ctx 'propagateIntoPast #t))
                         (set! late-texts (cons mark-grob late-texts)))))))
               (reverse events))
             (if (and first-grace-now
                  (null? events)
                  (not (ly:context-property ctx 'inhibitDummyRehearsalMark #f))
                 ) ;; create a dummy mark to get a BreakAlignment GROB ;-(
              (let* ((mark-grob (ly:engraver-make-grob trans 'RehearsalMark '()))
                     (null-label (make-null-markup)))
               (ly:grob-set-property! mark-grob 'outside-staff-horizontal-padding 0)
               (ly:grob-set-property! mark-grob 'padding 0)
               (ly:grob-set-property! mark-grob 'text null-label)
               (set! texts (cons mark-grob texts))
               (set! helper-text mark-grob)
             ))
             ;;; (for-each display (list "\n " (ly:context-current-moment ctx)
             ;;;    (if first-grace-now " first-grace-now" "")
             ;;;    (if late " late" "")
             ;;;    (if (null? b-a-g) "" " b-a-g")
             ;;;    (if (null? c-c-c) "" " c-c-c")
             ;;;    " END process-music\n"))
             ))

       (stop-translation-timestep
        . ,(lambda (trans)
             ;;; (for-each display (list "\n " (ly:context-current-moment ctx)
             ;;;    (if first-grace-now " first-grace-now" "")
             ;;;    (if late " late" "")
             ;;;    (if (null? b-a-g) "" " b-a-g")
             ;;;    (if (null? c-c-c) "" " c-c-c")
             ;;;    " START stop-translation-timestep\n"))
             (if (pair? texts)
                 (let ((staves (ly:context-property ctx 'stavesFound)))
                   (for-each (lambda (grob)
                     (let ((my-priority (ly:grob-property grob 'outside-staff-priority 1500)))
                      ;!! I'm not sure. May I realy skip this interface call for
                      ;!! RehearsalMarks I have to anchor at a past grace timing? 
                      (if (not (and late (ly:context-property ctx 'propagateIntoPast #t)))
                       (for-each (lambda (stave)
                         (ly:pointer-group-interface::add-grob
                          grob 'side-support-elements stave))
                        staves))
                      (if (ly:context-property ctx 'RehearsalMarkPriorityRenumbering #t) (begin
                        (set! (ly:grob-property grob 'outside-staff-priority) (+ my-priority priority-index))
                        (set! priority-index (1+ priority-index))))
                      (set! final-texts (cons grob final-texts))))
                  (reverse texts))
                (if (pair? late-texts)
                 (for-each (lambda (grob)
                   (if (not (null? b-a-g))
                    (set! (ly:grob-parent grob X) b-a-g))) late-texts))
                 (set! late-texts '())
                (set! texts '())))
             (set! events '())
             (if (= 0 (ly:moment-grace (ly:context-current-moment ctx)))
              (begin
               (if (not (null? helper-text)) (begin
                 (ly:grob-suicide! helper-text)
                 (set! helper-text '())))
               (set! b-a-g '())))
             ;;; (for-each display (list "\n " (ly:context-current-moment ctx)
             ;;;    (if first-grace-now " first-grace-now" "")
             ;;;    (if late " late" "")
             ;;;    (if (null? b-a-g) "" " b-a-g")
             ;;;    (if (null? c-c-c) "" " c-c-c")
             ;;;    " END stop-translation-timestep\n"))
           ))

        (finalize
         . ,(lambda (trans)
              (and (pair? final-texts)
                   (ly:context-property ctx 'RehearsalMarkVisibleAtEndOfContext #f)
                   (for-each (lambda (grob)
                               (set! (ly:grob-property grob 'break-visibility)
                                     end-of-line-visible))
                             final-texts)))))))

% copy of 'mark' from music-functions.ly, then extended:
polyMark =
#(define-music-function
   (parser location key label)
   (((lambda (x) (or (symbol? x)
                  (and (pair? x) (symbol? (car x))))) #f)
    (scheme? '()))
  "Make the music for the \\polyMark command."
  (let* ((set (and (integer? label)
		   (context-spec-music (make-property-set 'rehearsalMark label)
				      'Score)))
	 (ev (make-music 'MarkEvent
			 'origin location))
         (entry-key (if (symbol? key) key
                     (if (and (list? key) (symbol? (car key))) (car key)
                      #f))))
    (if (symbol? entry-key)
      (ly:music-set-property! ev 'key entry-key))
    (if (pair? key)
      (ly:music-set-property! ev 'additional-options (cdr key)))

    (if set
	(make-sequential-music (list set ev))
	(begin
	  (set! (ly:music-property ev 'label) label)
	  ev))))


%%% comment the following lines, if you do not want to turn it on by default
%%% and define it in the score block instead.
\layout {
 \context {
   \Score
   \remove "Mark_engraver"
   \consists #poly-mark-engraver
   \consists "Tweak_engraver"
 }
}

%%%%%%%%%%%%%%%%%%%%%%%%% TEST SUITE / EXAMPLES %%%%%%%%%%%%%%%%%%%%%%%%%
\layout {
  \context { \Score
    % inhibitDummyRehearsalMark = ##t
    % RehearsalMarkVisibleAtEndOfContext = ##t
    % RehearsalMarkPriorityRenumbering = ##f
  }
}

\paper {
  right-margin = 25 \mm
  left-margin  = 20 \mm
}
 

\score {
  \new Staff {
    \mark \default
    \polyMark #'T "Trio"
    \polyMark #'(X (direction . -1) (self-alignment-X . -1.0)) "Textmark below"
    c'1_\markup \with-color #blue "Extra Mark on buttom by 'differnt options on the fly' ..."
    d' e' f'
    \mark \default
    \polyMark #'(L (direction . -1)) \default
    g'_\markup \with-color #blue "... even with the same '\\default' marker."
    a' b' c''
    \mark \default
  }
  \header {
    piece = \markup \column {
      \line { \bold "1."
        \underline "Multiple RehearsalMarks if you assign them different keys:" }
      \line { "You can assign a key by using the new alternative to the" \bold "\\mark" "command, which is the" }
      \line { \bold "\\polyMark" "command." }
    }
  }
}

\score {
  \new Staff {
    \override Score.RehearsalMark.direction = #DOWN
    \mark \default
    \polyMark #'T "Trio"
    \polyMark #'(X (direction . 1) (self-alignment-X . -1.0)) "Textmark above"
    c'1^\markup \with-color #blue "Extra Mark on top by 'differnt options on the fly' ..."
    d' e' f'
    \mark \default
    \polyMark #'(L (direction . 1)) \default
    g'^\markup \with-color #blue "... even with the same '\\default' marker."
    a' b' c''
    \mark \default
  }
  \header {
    piece = \markup \line {
      \bold 2. \underline "Overriding GROB options on the fly does work if general overrides are set, too:"
    }
  }
}

MelodyII = {
  c'1
  \polyMark #'RightUp "RightUp"
  \polyMark #'RightDown "RightDown"
  d'
  \break
  \polyMark #'RightUp "RightUp"
  \polyMark #'RightDown "RightDown"
  e'
  \polyMark #'LeftUp "LeftUp"
  \polyMark #'LeftDown "LeftDown"
  f' \break
  \polyMark #'LeftUp "LeftUp"
  \polyMark #'LeftDown "LeftDown"
  g'
  \polyMark #'CenterUp "CenterUp"
  \polyMark #'CenterDown "CenterDown"
  a'_\markup \with-color #blue \column { "the default break-visibility is used for"
    \line { \bold "#'CenterUp" "and" \bold "#'CenterDown" } }
  \break
  \polyMark #'CenterUp "CenterUp"
  \polyMark #'CenterDown "CenterDown"
  b'
  \polyMark #'CenterEndUp "CenterEndUp"
  \polyMark #'CenterEndDown "CenterEndDown"
  c'' \break
  \polyMark #'CenterEndUp "CenterEndUp"
  \polyMark #'CenterEndDown "CenterEndDown"
}

\score {
  \new Staff {
    \MelodyII
  }
  \header {
    piece = \markup \line {
      \bold "3."
      \underline "Some 'keys' cause predefined default settings (direction, self-alignment-X, break-visibility):"
    }
  }
}
\noPageBreak
\markup { "Also available: Right, Left, Center and CenterEnd - they use the default direction." }

\pageBreak

PartI = {
  \repeat volta 2 { \repeat unfold 4 c''1 }
  \polyMark #'Fine \markup \italic "Fine"
  \polyMark #'SectionTitle \markup \bold \fontsize #2 "Trio"
  \repeat unfold 4 c''1
  \polyMark #'DC \markup \italic "Da Capo al Fine"
  \bar "|."
}

PartII = {
  \transpose c'' e' \PartI
}

\score {
  \new Staff { \PartI }
  \layout {
    \context { \Score
      polyMarkOptions = #`((Fine
                             (direction        . ,DOWN)
                             (self-alignment-X . 1.0)
                             (break-visibility . ,begin-of-line-invisible))
                           (DC
                             (direction        . ,DOWN)
                             (self-alignment-X . 1.0)
                             (break-visibility . ,begin-of-line-invisible))
                           (SectionTitle
                             (direction        . ,UP)
                             (self-alignment-X . -1.0)
                             (break-visibility . ,end-of-line-invisible)))
    }
  }
  \header {
    piece = \markup \line {
      \bold "4."
      \underline "You can define your own predefined 'keys' (at Score level, indepenent for each score) ..."
    }
  }
}

\score {
  <<
    \new Staff { \PartI }
    \new Staff { \PartII }
  >>
  \layout {
    \context { \Score
      polyMarkOptions = #`((Fine
                             (direction        . ,UP)
                             (self-alignment-X . 1.2)
                             (break-visibility . ,begin-of-line-invisible))
                           (DC
                             (direction        . ,UP)
                             (self-alignment-X . 1.0)
                             (break-visibility . ,begin-of-line-invisible))
                           (SectionTitle
                             (direction        . both)
                             (self-alignment-X . -1.0)
                             (break-visibility . ,end-of-line-invisible)))
    }
  }
  \header {
    piece = \markup \line {
      \bold "  "
      \underline "... and a value #'both for 'direction in this predefinition creates two RehearsalMarks."
    }
  }
}


MelodyIII = {
  \mark \default
  \polyMark #'T "Trio"
  c'1 d'
  \mark \default
  \polyMark #'(X (direction . -1)) \default
  e'
}

\score {
  <<
    \new Staff {
      \MelodyIII
    }
    \new Staff {
      \MelodyIII
    }
  >>
  \header {
    piece = \markup \line {
      \bold "5." \underline "Only one RehersalMark per 'key' is accepted for printing at a 'main time' in the score:"
    }
  }
}

MelodyIV = {
  \mark \default
  \polyMark #'T "Trio"
  \acciaccatura d'8 c'1 d'
  \mark \default
  \polyMark #'(X (direction . -1)) \default
  \grace { f'32 e' d' f' } e'1
}

\score {
  <<
    \new Staff {
      \MelodyIV
    }
    \new Staff {
      \MelodyIII
    }
  >>
  \header {
    piece = \markup \line {
      \bold "6."
      \underline "This purging is done over all grace time steps until the main moment is completed:"
    }
  }
}

MelodyV = {
  \acciaccatura d'8 c'1 d'
  \grace { f'32 e' d' f' } e'1
  \break
  \grace { g'32 f' e' g' } f'2
  \grace { a'16 fis' } g'2
  \key cis \major \time 8/8
  \grace { cis''16 gis' } ais'1
}

MelodyControlV = {
  \mark \default
  \polyMark #'T "Trio"
  s1 s
  \mark \default
  \polyMark #'(X (direction . -1)) \default
  s1
  \break
  \mark \default
  s2
  \mark \default
  s2
  \override Score.RehearsalMark.break-align-symbols = #'(key-signature clef)
  \mark \default
  s1_\markup \with-color #blue \column { "break-align-symbols =" "#'(key-signature clef)" }
}

\score {
  \new Staff {
    << { \MelodyV }
       { \MelodyControlV } >>
  }
  \header { piece = \markup \column {
    \line { \bold "7." 
      \underline "Even if the RehersalMarks are only defined in a 'parallel' control voice without grace skips,"
    }
    \underline "they will be printed before the grace notes (e.g. at the barline):"
  } }
}

\score {
  <<
    \new Staff {
      \set Score.propagateIntoPast = ##f
      << { \MelodyV }
         { \MelodyControlV } >>
    }
  >>
  \header { piece = \markup \column {
    \line { \bold "8. "
      \underline \line { "A new context property" \bold "propagateIntoPast" "(usually in the " \italic Score "context) will"
         "(if " \concat { \bold "##f" ")" } }
    }
    \underline \line { "turn off the mechanism which realigns the RehearsalMark before the grace notes:" } } }
}

%{
\score {
  \new Staff {
    \time 9/4
    \set Score.propagateIntoPast = ##f
    \repeat unfold 450
    \repeat unfold 9 {
      \grace d''8 c''4
    }
    \bar "|."
  }
  \header {
    piece = "MemoryCheck"
  }
}
%}