\version "2.19.64"

#(use-modules (ice-9 regex))
%#(use-modules (ice-9 rdelim))

#(define char-set:dynamics
  (char-set #\f #\m #\p #\r #\s #\z)) 
  
#(define separator-pair (cons #\{ #\}))

%% TODO
%% There's the scheme-procedure `make-regexp', I'm not confident with reg-exps 
%% to use it, though
#(define (make-reg-exp separator-pair)
  (format #f "\\~a[^~a~a]*\\~a"
    (car separator-pair)
    (car separator-pair)
    (cdr separator-pair)
    (cdr separator-pair)))
    
#(define (dynamics-list separator-pair strg)
;; Takes a string, which is splitted at space. Local reg-exp and separators are
;; processed from separator-pair.
;; Dynamic signs within the splitted string (which are rendered by separators)  
;; are selected by matching reg-exp and by containing only dynamic characters 
;; between the separators.
;; Those list elements are formated as a list of italic-markups for the
;; (possible parts) before and after the dynamic and dynamic-markup for the 
;; dynamic itself. Other list elements are left untouched.
;; Returns a new list.
;; 
;; Example:
;; (dynamics-list "\\{[^{}]*\\}" "poco {f}")
;; =>
;; (list "poco"
;;       (list (markup #:italic "")
;;             (markup #:dynamic "f")
;;             (markup #:italic "")))
;; 
  (let ((reg-exp (make-reg-exp separator-pair))
        (separators (char-set (car separator-pair) (cdr separator-pair))))

    (map
      (lambda (s)
        (let* ((match (string-match reg-exp s)))
           (if match 
               (let* ((poss-dyn (match:substring match))
                      (cand (string-trim-both poss-dyn separators)))
                 (if (string-every char-set:dynamics cand)
                       (list
                         (make-italic-markup (match:prefix match))
                         (make-dynamic-markup cand)
                         (make-italic-markup (match:suffix match)))
                     s))  
               s)))
      (string-split strg #\space))))

#(define (compose-markup markup-proc lst)
;; Takes a list and formats its elements with concat-markup (for sublists) or
;; italic-markup.
;; The resulting list is processed by markup-proc, usually 'make-line-markup'
;; or 'make-concat-markup'
;; Return this markup.
;; TODO? a check whether 'lst' and/or its elements is suitable does not happen
  (markup-proc
    (map
      (lambda (e)
        (if (list? e)
            (make-concat-markup e)
            (make-italic-markup e)))
      lst)))
      
#(define (get-all-list-indices lst)
;; Takes a list and returns a new list of indices of sublists in 'lst'
  (filter-map
    (lambda (e c) (if (list? e) c #f))
    lst
    (iota (length lst))))
    
#(define (note-column::main-extent grob)
;; Return extent of the noteheads in the "main column", (i.e. excluding any 
;; suspended noteheads), or extent of the rest (if there are no heads).
  (let* ((note-heads (ly:grob-object grob 'note-heads))
         (stem (ly:grob-object grob 'stem))
         (rest (ly:grob-object grob 'rest)))
    (cond ((ly:grob-array? note-heads)
           (let (;; get the cdr from all note-heads-extents, where the car 
                 ;; is zero
                 (n-h-right-coords
                   (filter-map
                     (lambda (n-h)
                       (let ((ext (ly:grob-extent n-h grob X)))
                          (and (= (car ext) 0) (cdr ext))))
                     (ly:grob-array->list note-heads))))
             ;; better be paranoid, find the max of n-h-right-coords and return
             ;; a pair with (cons 0 <max>)
             (cons 0.0 (reduce max 0 n-h-right-coords))))
          ((ly:grob? rest)
           (ly:grob-extent rest grob X))
          ;; better be paranoid
          (else '(0 . 0)))))
  
#(define (get-some-markups lst idx)
;; 'lst' is a list of strings and/or markup-lists, usually processed by
;; 'dynamics-list'
;; 'idx' selects from (get-all-list-indices lst) 
;;
;;
;; Identify the dynamic expression, by 'idx'.  This dynamic expression may
;; contain other stuff, though.
;;
;; Get the stuff which is before the dynamic expression.
;; Get the stuff which may be before the dynamic, but should not rendered
;; with a dynamic font.
;; Get the dynamic, which should be centered below NoteColumn later.
;; Get the entire markup.
;;
;; Returns a list of above in this order.
;;
;; This list will be used later to calculate the values for X-offset to center
;; the identified dynamic below the NoteColumn
;;
;; Example:
;;     (display-scheme-music 
;;       (get-some-markups (dynamics-list (cons #\{ #\}) "poco {f}") 0))
;;     =>
;;     (list (markup #:concat (#:italic "poco" #:italic " "))
;;           (markup #:italic "")
;;           (markup #:dynamic "f")
;;           (markup
;;             #:line
;;             (#:italic
;;              "poco"
;;              #:concat
;;              (#:italic "" #:dynamic "f" #:italic ""))))

  (let ((all-dyn-indices (get-all-list-indices lst))
        (complete-lst-mrkp (compose-markup make-line-markup lst)))
    (if (null? all-dyn-indices)
        (list '() '() '() complete-lst-mrkp)
        (let* (;; if idx exceeds, print a warning and use first possible
               ;; dynamic
               (dyn-pos 
                 (if (>= idx (length all-dyn-indices))
                     (begin
                       (ly:warning 
                         "requested dynamic to align does not exist, ignoring")
                       (car all-dyn-indices))
                     (list-ref all-dyn-indices idx)))
               (before-part (take lst dyn-pos))
               (before-ls 
                 (if (null? before-part) 
                     '() 
                     ;; put in " " between every element and at the end of 
                     ;; 'before-part'
                     ;;
                     ;; It would more convenient to use make-line-markup in
                     ;; in 'before-mrkp' below, but I don't know how to insert
                     ;; _single_ space at the end of make-line-markup, other
                     ;; than:
                     ;;     (make-concat-markup
                     ;;       (make-line-markup (list ...))
                     ;;       " ")
                     ;; which is clumsy as well.
                     (append 
                       (list-insert-separator before-part " ") 
                       '(" "))))
               (before-mrkp (compose-markup make-concat-markup before-ls))
               (dyn-expr (list-ref lst dyn-pos))
               (first-part-dyn-expr (car dyn-expr))
               (dyn-to-center (second dyn-expr)))

         (list
           before-mrkp
           first-part-dyn-expr
           dyn-to-center
           complete-lst-mrkp)))))

dynamicH =
#(define-event-function (align-on-dyn? idx strg) 
  ((boolean? #f)(index? 1) string?)
;; Takes a string, puts out a formated dynamic-script using dynamic font for 
;; identified DynamicText, italic for all other stuff.
;; This text is placed below the NoteColumn, with first occurring DynamicText
;; centered. 
;;
;; Setting the optional @var{idx} makes it possible to choose other
;; occurring DynamicText.
;; If some other text is before the DynamicText it will be printed left
;; aligned.  This may be changed by setting optional @var{align-on-dyn}.
;;
;; Be aware while using any optional variable you need to set both.
;; 
;; The appearance is futher tweakable by applying tweaks for self-alignment-X
;; and X-offset.
;; If using a tweak for self-alignment-X the calculated value for X-offset will 
;; not be used.
;; If using a tweak for X-offset, this value will be added to the calculated 
;; one.
;; 
;; Limitations: 
;;   - Does not respond to _overrides_ of self-alignment-X


  (let* (;; list-ref starts with zero for the first element, thus use (1- idx) 
         ;; for a nicer user-interface
         (info (get-some-markups (dynamics-list separator-pair strg) (1- idx)))
         (dynamic
           (make-music 'AbsoluteDynamicEvent
                       'text (make-normal-text-markup (last info))))
         (x-off-proc
           (lambda (grob)
             (let* ((calculated-x-off
                      (if (markup? (third info))
                          (let* ((layout (ly:grob-layout grob))
                                 (props 
                                   (ly:grob-alist-chain grob
                                     (ly:output-def-lookup 
                                       layout 
                                       'text-font-defaults)))
                                 ;; get the parent NoteColumn
                                 (x-parent (ly:grob-parent grob X))
                                 (parent-x-ext-center 
                                   (interval-center 
                                     (if (ly:grob-property grob 
                                           'X-align-on-main-noteheads)
                                         (note-column::main-extent x-parent)
                                         (ly:grob-extent x-parent x-parent X))))
                                 ;; get the lengths of the stencils for the 
                                 ;; first three entries of 'info'
                                 (stils-x-length-lst
                                   (map
                                     (lambda (e)
                                       (interval-length
                                         (ly:stencil-extent
                                           (interpret-markup 
                                             layout 
                                             props 
                                             (make-normal-text-markup e))
                                         X)))
                                     (take info 3))))

                            ;; The final calculation takes the extent of the 
                            ;; NoteColumn into account.
                            ;; If there is some other text before the dynamic, 
                            ;; return 0, but not if align-on-dyn is #t
                            (if (or (zero? (car stils-x-length-lst)) 
                                     align-on-dyn?)
                                (- parent-x-ext-center
                                   (car stils-x-length-lst)
                                   (second stils-x-length-lst)
                                   (/ (third stils-x-length-lst) 2))
                                0))
                           
                          ;; if no dynamic at all, do (my choice):
                          0))
                    ;; get tweaks for self-alignment-X
                    (prev-self-alignment-X-tweaks
                      (filter
                        (lambda (tw)
                          (eq? (car tw) 'self-alignment-X))
                        (ly:prob-property 
                          (ly:grob-property grob 'cause) 
                          'tweaks)))
                    ;; Get previous tweaks for X-offset and add their values
                    ;; They are added to the final result  
                    (prev-x-offset-tweaks
                      (filter
                        (lambda (tw)
                          (and (number? (cdr tw)) (eq? (car tw) 'X-offset)))
                        (ly:prob-property 
                          (ly:grob-property grob 'cause) 
                          'tweaks)))
                    (prev-x-off (apply + (map cdr prev-x-offset-tweaks))))

             ;; if previous tweaks for self-alignment-X are present return '()
             (if (not (pair? prev-self-alignment-X-tweaks))
                 (ly:grob-set-property! grob
                   'X-offset (+ prev-x-off calculated-x-off))
                 '())))))
    ;; If a previous tweak for self-alignment-X is present, set 
    ;; 'before-line-breaking to the empty list retuned by x-off-proc for this
    ;; case
    ;; Otherwise 'before-line-breaking will change 'X-offset to the calculated
    ;; value returned from x-off-proc (taking previous tweaks for 'X-offset
    ;; into account.
    ;; TODO need to keep previous settings of 'before-line-breaking?
    (set! (ly:music-property dynamic 'tweaks)
          (acons 'before-line-breaking
                 x-off-proc
                 (ly:music-property dynamic 'tweaks)))
    dynamic))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%#(define tst "foo [[[[[{fff}]!, poco {f}, but {p} sub. {ma} non troppo {fff}")
%#(define tst "[[[[[{fff}]!, poco {f}, but {p} sub. {ma} non troppo") 
#(define tst "{fff} poco {f}, but {p} sub. {ma} non troppo")
%#(define tst "{pp}, but {p} sub. {ma} non troppo")
%#(define tst "{f}")
%#(define tst "foo")
%#(define tst "poco {f}")


\score {
  <<
    \new Staff \with { instrumentName = "\\dynamicH" } 
      { c'1 \dynamicH \tst }
      
    \new Staff 
      \with { 
        instrumentName = 
          \markup \center-column { "\\dynamicH" "\\tweak" "self-alignment-X" }
      } 
      { c'1 -\tweak self-alignment-X #RIGHT \dynamicH \tst }
      
    \new Staff 
      \with { 
      	instrumentName = 
          \markup \center-column { "\\dynamicH" "\\tweak" "X-offset" }
      } 
      { c'1 -\tweak X-offset 1 \dynamicH \tst }
      
    %% defaults
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \fff }
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \ff }
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \f }
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \ppp }
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \pp }
    \new Staff \with { instrumentName = "default-dynamic" } { c'1 \p }
    
    \new Staff 
      \with { 
        instrumentName = 
          \markup \center-column { "\\dynamicH" "suspended Heads" }
      }
      { <c' d'>1 \dynamicH  \tst }
      
    \new Staff \with { instrumentName = "default-dynamic" } { <c' d'>1 \fff }
    
    %% helper for better viewing
    \addlyrics \with { \override LyricText.parent-alignment-X = #LEFT }
      { \markup \with-dimensions #'(0 . 0) #'(0 . 0) \draw-line #'(0 . 160) }
  >>
}

\score {
  <<
    \new Staff 
      \with { instrumentName = "\\dynamicH" }
      { c''\dynamicH "{fffff} dramatically" }
      
    \new Staff 
      \with { instrumentName = "\\dynamicH" }
      { c''\dynamicH "{fffff},,,,,,,,,, dramatically" }
      
    \new Staff 
      \with { 
        instrumentName = 
          \markup \center-column { "\\dynamicH" "\\tweak" "self-alignment-X" }
      }
      { 
        c''-\tweak self-alignment-X #LEFT 
           \dynamicH  "poco {f}, but {p} sub. ma non troppo" 
      }
      
    \new Staff  
      \with { instrumentName = "\\dynamicH" }
      { c''\dynamicH "poco {f}, but {p} sub. ma non troppo" }
      
    \new Staff  
      \with { 
        instrumentName = 
          \markup \center-column { 
            "\\dynamicH" 
            "align-on-dyn? ##t" 
            "idx 1" 
            "->align on first Dynamic" 
            "although other text" 
            "is before" 
          }
      }
      { c''\dynamicH ##t 1  "poco {f}, but {p} sub. ma non troppo" }
    \new Staff   
      \with { 
        instrumentName = 
          \markup \center-column { 
            "\\dynamicH" 
            "align-on-dyn? ##t" 
            "idx 2" 
            "->align on second Dynamic" 
            "although other text" 
            "is before" 
          }
      }
      { c''\dynamicH ##t 2  "poco {f}, but {p} sub. ma non troppo" }
      
    \new Staff 
      \with {
        instrumentName =
          \markup \center-column { "\\dynamicH" "\\tweak" "self-alignment-X" }
      }
      { 
        c''-\tweak self-alignment-X #RIGHT 
           \dynamicH  "poco {f}, but {p} sub. ma non troppo" 
      }
      
    \new Staff 
      \with {
        instrumentName =
          \markup \center-column { 
            "\\dynamicH" 
            "\\tweak" 
            "self-alignment-X" 
            "DynamicText.parent-alignment-X"
            "LEFT"
          }
      }
      { 
    	  \override DynamicText.parent-alignment-X = #LEFT
    	  cis''-\tweak self-alignment-X #RIGHT 
    	     \dynamicH  "poco {f}, but {p} sub. ma non troppo" 
      }
      
    \new Staff   
      \with { 
        instrumentName = 
          \markup \center-column { 
            "\\dynamicH" 
            "align-on-dyn? ##t" 
            "idx 1" 
            "->align on first Dynamic" 
            "although other text" 
            "is before" 
          }
      }
      { c''\dynamicH ##t 1 "slightly more {pp}" }

    \new Staff    
      \with { 
        instrumentName = 
          \markup \center-column { 
            "\\dynamicH" 
            "align-on-dyn? ##t" 
            "idx 3" 
            "->align on third Dynamic" 
            "although other text" 
            "is before" 
          }
      }
      { 
        c''\dynamicH ##t 3
                     "[{f}], but [{p}] sub. ma non troppo, segue {mf}" 
           _\markup
             \halign #CENTER
             \rounded-box "Above mezzoForte is (very) little off, no clue why"
             %% rounding somewhere??
             %% blot-diameter??
      }
      
    \new Staff \with { instrumentName = "default-dynamic" }
      { c''\dynamicH "{mf}" }
      
    \new Staff \with { instrumentName = "default-dynamic" }
      { c''\mf }
      
    %% helper for better viewing
    \addlyrics \with { \override LyricText.parent-alignment-X = #LEFT }
      { \markup \with-dimensions #'(0 . 0) #'(0 . 0) \draw-line #'(0 . 160) }
  >>
}

\paper { indent = 5 \cm }

\layout {
  %\override DynamicText.stencil =
  %  #(lambda (grob) (box-stencil (ly:text-interface::print grob) 0 0))
  \context {
    \Staff
    \override InstrumentName.font-size = -2
    \override InstrumentName.baseline-skip = 2
    \override InstrumentName.stencil =
      #(lambda (grob)
        (box-stencil
          (system-start-text::print grob)
          0 1))
  }
}