\version "2.19.64"

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

#(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)))))

%% TODO #\space as well?
#(define char-set:dynamics
  (char-set #\f #\m #\p #\r #\s #\z)) 

%% 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 @var{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.  
;;
;; Returns a new list containing not-dynamic strings and sublists with always
;; three entries.  Before-the-dynamic - dynamic - after-dynamic.
;; 
;; Example:
;; (dynamics-list (cons #\{ #\}) "poco -{f}- piu"))
;; =>
;; (list "poco" (list "-" "f" "-") "piu")
;; 
  (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
                         (match:prefix match)
                         cand
                         (match:suffix match))
                     s))  
               s)))
      (string-split strg #\space))))
      
#(define (get-all-list-indices lst)
"Takes a list and returns a new list of all indices of sublists in @var{lst}"
  (filter-map
    (lambda (e c) (if (list? e) c #f))
    lst
    (iota (length lst))))

#(define (dynamic-text::format-dynamics fontsize markup-command lst)
;; (1) Convert lst into a list where the targeted string is rendered
;;     with dynamic-markup.  The targeted string is identified by being
;;     second in a three-element-(sub-)list of lst.
;; (2) remove empty strings from (sub-)lists.
;; (3) insert " " between any element of lst but not between
;;     elements of the (sub-)lists
;; (4) Return a new list, unfolded one level
;; TODO disentangle applying markup-commands from other stuff?
    (append-map
      (lambda (y) (if (list? y) y (list y)))
      (list-insert-separator
        (map
          (lambda (e)
            (if (and (list? e) (= (length e) 3))
                (remove
                   (lambda (x) (and (string? x) (string-null? x)))
                   (list
                     (car e)
                     (if (number? fontsize)
                         (make-fontsize-markup fontsize
                           (markup-command (second e)))
                         (markup-command (second e)))
                     (last e)))
                e))
          lst)
        " ")))
        
#(define (dynamic-text::format-text fontsize markup-command lst)
"Format string-parts of @var{lst} with @var{fontsize} and @var{markup-command}"
  (map
    (lambda (arg)
      (if (string? arg)
          (if (number? fontsize)
              (make-fontsize-markup fontsize
                (markup-command arg))
              (markup-command arg))
          arg))
    lst))
           
#(define (get-list-parts lst dyn-indices idx)
;; Relying on @var{idx}, which selects from @var{dyn-indices} return a new
;; list containing sublists with stuff before the selected dynamic, the
;; dynamic itself and stuff after the dynamic.
  (if (null? dyn-indices)
      (list '() '() '())
      (let* (;; if idx exceeds, print a warning and use first possible
             ;; dynamic
             (dyn-pos 
               (if (>= idx (length dyn-indices))
                   (begin
                     (ly:warning 
                       "requested dynamic to align does not exist, ignoring")
                     (car dyn-indices))
                   (list-ref dyn-indices idx)))
             (before-dyn (take lst dyn-pos))
             (dyn-to-align (list-ref lst dyn-pos))
             (after-dyn (drop lst (1+ dyn-pos))))
        (list
          before-dyn
          dyn-to-align
          after-dyn))))
  
dynamicH =
#(define-event-function (align-on-dyn? idx strg) 
  ((boolean? #f)(index? 1) string?)
;; Takes a string, puts out a formated dynamic-script using a certain 
;; markup-command for identified DynamicText, and another markup-command for all 
;; other stuff.
;; Both markup-commands are called from 'details.markup-commands. If not set
;; make-dynamic-markup and make-italic-markup are used.
;; Font-sizes for both are called from 'details.dyn-rest-font-sizes. If not set
;; default is used.
;; 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* ((dynamic (make-music 'AbsoluteDynamicEvent))
         (tweak-proc
           (lambda (grob)
             (let* (;; get the fontsizes to use from the relevant 
                    ;; details-sub-property, i.e. 'dyn-rest-font-sizes
                    (dyn-rest-font-sizes 
                      (assoc-get 
                        'dyn-rest-font-sizes 
                        (ly:grob-property grob 'details)
                        (cons #f #f)))
                    ;; get the markup-commands to use from the relevant 
                    ;; details-sub-property, i.e. 'markup-commands
                    (markup-commands 
                      (assoc-get 
                        'markup-commands 
                        (ly:grob-property grob 'details)
                        (cons make-dynamic-markup make-italic-markup)))
                    (separator-pair
                      (assoc-get 
                        'separator-pair 
                        (ly:grob-property grob 'details)
                        (cons #\{ #\})))
                    ;; get a nested list with dynamics in sublists
                    (basic-dyn-list (dynamics-list separator-pair strg))
                    ;; do dynamic-markups, remove empty strings
                    (cleaned-basic-dyn-list 
                      (dynamic-text::format-dynamics 
                          (car dyn-rest-font-sizes) 
                          (car markup-commands) 
                          basic-dyn-list))
                    ;; get indices of dynamics
                    (all-dyn-indices 
                      (get-all-list-indices cleaned-basic-dyn-list))
                    ;; do other text-markups
                    (text-dyn-mrkp-list 
                      (dynamic-text::format-text 
                        (cdr dyn-rest-font-sizes)
                        (cdr markup-commands)
                        cleaned-basic-dyn-list))
                    ;; get a list containing: 
                    ;;   before-dynamic, dynamic, after-dynamic
                    ;; list-ref starts with zero for the first element, thus 
                    ;; use (1- idx) for a nicer user-interface
                    (splitted-text-dyn-mrkp-list 
                      (get-list-parts 
                        text-dyn-mrkp-list all-dyn-indices (1- idx)))
                    (all-markups
                      (map
                        (lambda (e)
                          (if (markup-list? e)
                              (make-normal-text-markup
                                (make-concat-markup e))
                              e))
                        splitted-text-dyn-mrkp-list))
                    (all-stils
                      (map
                        (lambda (mrkp)
                          (grob-interpret-markup grob mrkp))
                        all-markups))
                    (layout (ly:grob-layout grob))
                    (line-thick (ly:output-def-lookup layout 'line-thickness))
                    (all-stil-lengths
                      (map
                        (lambda (stil)
                          (let* ((stil-ext (ly:stencil-extent stil X))
                                 (left-car (if (interval-sane? stil-ext) 
                                           (car stil-ext)
                                           0))
                                 ;; if the markup-command used to render 
                                 ;; dynamics, causes negative extent to the left
                                 ;; and the entire dynamic expression starts
                                 ;; with an empty stencil, it's needed to add
                                 ;; some calculated correction
                                 (corr
                                   (+ (* 2 left-car)
                                   (/ line-thick 2))))
                            (+ 
                              (interval-length stil-ext) 
                              (if (ly:stencil-empty? (car all-stils))
                                  corr
                                  0))))
                        all-stils))
                    (calculated-x-off
                      (if (markup? (second all-markups))
                          (let* ((x-par (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-par)
                                         (ly:grob-extent x-par x-par X)))))
                            ;; 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 all-stil-lengths)) 
                                    align-on-dyn?)
                                (- parent-x-ext-center
                                   (car all-stil-lengths)
                                   (/ (second all-stil-lengths) 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))))

             ;; TODO is it safe to put the stencil-creation into 
             ;;      'before-line-breaking?
             (begin
               (ly:grob-set-property! grob 'stencil
                (stack-stencils X RIGHT 0 all-stils))
               ;; 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
                 tweak-proc
                 (ly:music-property dynamic 'tweaks)))
    dynamic))

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

%% REMARKS
%% All examples align the dynamic under the NoteColumn
%% Remove the optional arguments in 
%%    \dynamicH ##t 1 ...
%% if you want different behaviour
%%
%% Some examples use fonts Purisa and LilyJazz, make sure you have them

%#(set-default-paper-size "a4")

\paper { indent = 5 \cm  }

layoutDefault =
  \layout {
  	%% DynamicText may be customized with overrides as below.
  	%% Currently given are the defaults.
  	%
    %\override DynamicText.details.separator-pair = #(cons #\{ #\})
    %
    %% first value of the pair is used to determine fontsize of dynamics, second
    %% for other text
    %\override DynamicText.details.dyn-rest-font-sizes = #'(0 . 0)
    %
    %% first value of the pair is used to render dynamics, second for other text
    %% Be aware: if you change/extend the simple make-dynamic-markup, but
    %% want to have the dynamics _all_ rendered with dynamic-font wrap your new
    %% command around make-dynamic-markup
    %\override DynamicText.details.markup-commands = 
    %  #(cons make-dynamic-markup make-italic-markup)
    %
    %\override DynamicText.font-size = 0
  }
  
%% Change fontsize independently
layoutI =
  \layout {
  	  \override DynamicText.details.dyn-rest-font-sizes = #'(3 . -2)
  }

%% Change used markup-commands independently
layoutII =
  \layout {
  	\override DynamicText.details.dyn-rest-font-sizes = #'(5 . 0)
    \override DynamicText.details.markup-commands =
      #(cons
         (lambda (arg)
           (markup 
             #:normal-text 
             #:override '(box-padding . 0.5) 
             #:override '(thickness . 3) 
             #:box 
             #:bold 
             #:override '(font-name . "LilyJazz")
             arg))
         (lambda (arg) 
           (markup
             ;; Limitation:
             ;; underline returns a nice output by accident!
             ;; undertie not
             ;; Reason: every single part of the text markup needs to be 
             ;; processed separately, otherwise the offsetting calculation will
             ;; be broken
             #:underline
             #:override '(font-name . "Purisa")
             arg)))
  }
  
%% Change used markup-commands independently
%% Other syntax
layoutIII =
  \layout {
    \override DynamicText.details.markup-commands =
      #(cons 
         (lambda (arg)
           #{ 
           	   \markup 
           	     \override #'(padding . 0.7) 
           	     \override #'(thickness . 2.5) 
           	     %% REMARK to self:
           	     %% patch make-bracket-markup, its thickness is not customizable
           	     \parenthesize 
           	     \dynamic
           	     $arg 
           #})
         (lambda (arg) #{ \markup \bold $arg #}))
    \override DynamicText.font-size = 0
  }
  
%% Change used markup-commands independently
%% Again other syntax

\markup customize-dyn = 
  \markup \ellipse \dynamic \etc
  
\markup with-red = 
  \markup \with-color #red \etc

layoutIV =
  \layout {
    \override DynamicText.details.markup-commands =
      #(cons make-customize-dyn-markup make-with-red-markup)
    \override DynamicText.font-size = 0
  }
  
%% \dynamicH takes two optional arguments, see above.
%% As soon as more sophisticated markup-commands are used to render the dynamic
%% part using them is recommended.
%% For the sake of the examples shortness, they are always applied here
mus =
  <<
    \new Staff { c''1\dynamicH ##t 1 "text before {ppppp}" }

    \new Staff { c''1\dynamicH ##t 1 "{ppppp} text after" }

    \new Staff { c''1\dynamicH ##t 1 "text before {ppppp} text after" }
    %% helper for better viewing
    \addlyrics %\with { \override LyricText.parent-alignment-X = #LEFT }
      { \markup \with-dimensions #'(0 . 0) #'(0 . 0) \draw-line #'(0 . 30) }
  >>
  
\score { \mus \layoutDefault \header { piece = "DEFAULTS" } }

\score { \mus \layoutI \header { piece = "FONTSIZES" } }

\score { \mus \layoutII \header { piece = "MARKUP-COMMANDS" } }

\score { \mus \layoutIII \header { piece = "MARKUP-COMMANDS" } }

\score { \mus \layoutIV \header { piece = "MARKUP-COMMANDS" } }

\score { 
  \new Staff { c''1\dynamicH ##t 1 "text before _ppppp_ text after" }
  \layout {
    \override DynamicText.details.separator-pair = #(cons #\_ #\_)
  }
  \header { piece = "Changed SEPARATOR-PAIR (no visible changes)" } 	
}

\score { 
  \new Staff { c''1\dynamicH ##t 2 "center on {ppppp} second {ff} dynamic" }
  \layoutIV
  \header { piece = "CENTER ON SECOND DYNAMIC" } 	
}