%%%% written for 2.19.65


%% To test the example below uncomment:
%\include "etym-III-scheme.ly"

#(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 remove-empty
  ;; Remove empty strings and empty lists from the given list 'lst'
  (lambda (lst)
    (remove
      (lambda (e)
        (or
          (and (string? e) (string-null? e))
          (and (list? e) (null? e))))
      lst)))
      
#(define char-set:dynamics
  (char-set #\f #\m #\p #\r #\s #\z))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% DynamicText, created on the fly
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% Reads
%%%%  DynamicText.details.separator-pair
%%%%  DynamicText.details.dyn-rest-font-sizes
%%%%  DynamicText.details.markup-commands
%%%%  DynamicText.details.inner-x-space
%%%%  DynamicText.details.outer-x-space


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

#(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)
  (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 (dynamic-text::format-text
           fontsizes inner-kern outer-kern text-markup-command lst)
  (let* ((mrkp-cmnd
           (lambda (arg) (make-normal-text-markup (text-markup-command arg))))
         (txt-font-size (if (pair? fontsizes) (cdr fontsizes) #f))
         (txt-mrkp-cmnd
           (lambda (txt)
             (if (number? txt-font-size)
                 (make-fontsize-markup txt-font-size (mrkp-cmnd txt))
                 (mrkp-cmnd txt))))
         (left-out (if (pair? outer-kern) (car outer-kern) #f))
         (left-inner (if (pair? inner-kern) (car inner-kern) #f))
         (right-inner (if (pair? inner-kern) (cdr inner-kern) #f))
         (right-out (if (pair? outer-kern) (cdr outer-kern) #f))
         (space-mrkp-cmd
           (lambda (space)
             (if (number? space)
                 (txt-mrkp-cmnd (make-hspace-markup space))
                 ""))))
    (map
      (lambda (e)
        (if (list? e)
            (remove-empty
              (list
                (cond ((and (string-null? (car e)) (equal? e (car lst))) '())
                      ((string-null? (car e))
                        (space-mrkp-cmd left-out))
                      ((and (not (string-null? (car e))) (equal? e (car lst)))
                        (make-concat-markup
                        (remove-empty
                          (list
                            (txt-mrkp-cmnd (car e))
                            (space-mrkp-cmd left-inner)))))
                      (else
                        (make-concat-markup
                        (remove-empty
                          (list
                            (space-mrkp-cmd left-out)
                            (txt-mrkp-cmnd (car e))
                            (space-mrkp-cmd left-inner))))))
                (second e)
                (cond ((and (string-null? (last e)) (equal? e (last lst))) '())
                      ((string-null? (last e))
                        (space-mrkp-cmd right-out))
                      ((and (not (string-null? (last e)))
                            (equal? e (last lst)))
                        (make-concat-markup
                        (remove-empty
                          (list
                            (space-mrkp-cmd right-inner)
                            (txt-mrkp-cmnd (last e))))))
                      (else
                        (make-concat-markup
                        (remove-empty
                          (list
                            (space-mrkp-cmd right-inner)
                            (txt-mrkp-cmnd (last e))
                            (space-mrkp-cmd right-out))))))))
            (make-line-markup (list (txt-mrkp-cmnd e)))))
      lst)))

#(define (get-string-indices lst)
  (filter-map
    (lambda (e c) (if (string? e) c #f))
    lst
    (iota (length lst))))

#(define (dynamic-text::structered-list
           separators fontsizes inner-kern outer-kern markup-commands idx strg)
  (let* ((ls (dynamics-list separators strg))
         (dynamic-fontsize (if (pair? fontsizes) (car fontsizes) #f))
         (dyn-mrkp-cmnd (car markup-commands))
         (dynamic-mrkp-cmnd
           (lambda (txt)
             (if (number? dynamic-fontsize)
                 (make-fontsize-markup dynamic-fontsize
                   (make-normal-text-markup (dyn-mrkp-cmnd txt)))
                 (make-normal-text-markup (dyn-mrkp-cmnd txt)))))
         (formated-dyns
           (dynamic-text::format-text
             fontsizes
             inner-kern
             outer-kern
             (cdr markup-commands)
             ls))
         (spaced-formated-dyns
           (list-insert-separator formated-dyns (make-simple-markup " ")))
         (spaced-plain
           (append-map
             (lambda (y) (if (markup-list? y) y (list y)))
             spaced-formated-dyns))
         (spaced-with-dyn
           (map
             (lambda (e)
               (if (string? e)
                   (dynamic-mrkp-cmnd e)
                   e))
             spaced-plain))
         (string-spaced-indices (get-string-indices spaced-plain))
         ;; if idx exceeds, print a warning and use first possible
         ;; dynamic
         ;; if idx is negative, due to (1- idx) in the function-body of dynamicH
         ;; return #f, same for if (null? string-spaced-indices). Meaning no
         ;; dynamics are indicated.
         ;; This will finally return (with dynamicH) a left align dynamic.
         (dyn-pos
           (cond ((or (negative? idx) (null? string-spaced-indices)) #f)
                 ((>= idx (length string-spaced-indices))
                   (begin
                     (ly:warning
                       "requested dynamic to align does not exist, ignoring")
                     (car string-spaced-indices)))
                 (else (list-ref string-spaced-indices idx))))
         ;(foo (format #t "##########: ~a\n"  dyn-pos))
         ;; NB: values!
         (splitted-at-dyn-index
           (if dyn-pos
               (split-at spaced-with-dyn dyn-pos)
               spaced-with-dyn)))
    (if (list? splitted-at-dyn-index)
        splitted-at-dyn-index
        (let-values (((before dyn&else) splitted-at-dyn-index))
          (cons*
             before
             (if (pair? dyn&else)
                 (list (car dyn&else) (cdr dyn&else))
                 dyn&else))))))

dynamicH =
#(define-event-function (parser location idx strg)
  ((index? 1) string?)
  "Returns customized DynamicText derived from @var{strg}.
Parts which should be rendered with as dynamics should be entered by
surrounding them with the elements of @code{details.separator-pair}, default is
@code{(cons #\\{ #\\})}.
The output is done by using the procedures from @code{details.markup-commands},
defaulting to @code{(cons make-dynamic-markup make-italic-markup)}.
Further customizing is possible by using
@code{details.dyn-rest-font-sizes}, needs a pair, default is unset
@code{details.inner-x-space}, needs a pair, default is unset
@code{details.outer-x-space}, needs a pair, default is is unset
The optional @var{idx} determines which dynamic part is centered under the
NoteColumn (in case @var{strg} contains multiple dynamics).
"
  (let* ((dynamic (make-music 'AbsoluteDynamicEvent))
         (tweak-proc
           (lambda (grob)
             (let* (
                    (separator-pair
                      (assoc-get
                        'separator-pair
                        (ly:grob-property grob 'details)
                        (cons #\{ #\})))
                    ;; 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)))
                    ;; get the markup-commands to use from the relevant
                    ;; details-sub-property, i.e. 'markup-commands, a pair
                    ;; car for dynamic, cdr for the rest
                    (markup-commands
                      (assoc-get
                        'markup-commands
                        (ly:grob-property grob 'details)
                        (cons make-dynamic-markup make-italic-markup)))
                    ;; get the pair-value to use for inserting some space to the
                    ;; left and/or right of the dynamic, usefull for bracketed
                    ;; dynamics or dynamics with punctuations
                    (inner-kern
                      (assoc-get
                        'inner-x-space
                        (ly:grob-property grob 'details)))
                    ;; get the pair-value to use for inserting some space
                    ;; between the dynamic expression and other text.
                    (outer-kern
                      (assoc-get
                        'outer-x-space
                        (ly:grob-property grob 'details)))
                    (stil-candidates
                      (dynamic-text::structered-list
                        separator-pair
                        dyn-rest-font-sizes
                        inner-kern
                        outer-kern
                        markup-commands
                        (1- idx)
                        strg))
                    (all-stils
                      (map
                        (lambda (mrkp)
                          (if (null? mrkp)
                              empty-stencil
                              (grob-interpret-markup grob
                                (if (markup-list? mrkp)
                                    (make-concat-markup mrkp)
                                    mrkp))))
                          stil-candidates))
                    (prev-self-alignment-X-tweaks
                      (filter
                        (lambda (tw)
                          (eq? (car tw) 'self-alignment-X))
                        (ly:prob-property
                          (ly:grob-property grob 'cause)
                          'tweaks))))

             (begin
               ;; Next line should be used for 2.19.65 and above
               ;(ly:grob-set-property! grob 'stencil
               ;  (stack-stencils X RIGHT 0 all-stils))
               ;; This line is for 2.18.2, though sometimes the offset in x-axis
               ;; is a little off
               (ly:grob-set-property! grob 'text
                 (make-stencil-markup (stack-stencils X RIGHT 0 all-stils)))
               ;; if previous tweak for self-alignment-X is present return '()
               (if (pair? prev-self-alignment-X-tweaks)
                   '()
                   (ly:grob-set-property! grob 'X-offset
                     (let* ((x-exts
                              (map
                                (lambda (stil) (ly:stencil-extent stil X))
                                (take all-stils 2)))
                            (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))))
                            ;; 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 (markup-list? stil-candidates)
                           ;; For text only or if idx is set zero: align center.
                           ;; Also possible would be to left align, by switching
                           ;; to zero.
                           (ly:grob-property grob 'X-offset)
                           ;
                           (+
                              prev-x-off
                              (-
                                 parent-x-ext-center
                                 (interval-length (car x-exts))
                                 (/ (interval-length (second x-exts)) 2)
                                 (cond ((and (ly:stencil-empty? (car all-stils))
                                          (negative? (car (second x-exts))))
                                        (car (second x-exts)))
                                       ((negative? (car (first x-exts)))
                                        (car (first x-exts)))
                                       (else 0)))))))))))))

    (set! (ly:music-property dynamic 'tweaks)
          (acons 'before-line-breaking
                 tweak-proc
                 (ly:music-property dynamic 'tweaks)))
    dynamic))


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% {

\version "2.19.65"
tst = "foo {mf} poco, poco ---{f}- piu, {p}! {f} {p} {ff} {ppp}"
%tst = "{mf} poco, poco -{f}- piu ,{p}! {f} {p} {ff} {ppp}"
%tst = "some text only"

\score {
  <<
  \new Staff \with { instrumentName = "\\dynamicH" }
    { c'1\dynamicH 2 \tst }
  \new Staff \with { instrumentName = "default" }
    { c'1 -$(make-dynamic-script
              (make-normal-text-markup
                (make-italic-markup "some text only"))) }
  \new Staff \with { instrumentName = "default" }
    { c'1 \mf }
  \new Staff \with { instrumentName = "default" }
    { c'1 \f }
  \new Staff \with { instrumentName = "default" }
    { c'1 \p }
  %% helper for better viewing
  \addlyrics % \with { \override LyricText.parent-alignment-X = #LEFT }
    { \markup \with-dimensions #'(0 . 0) #'(0 . 0) \draw-line #'(0 . 300) }
  >>
  \layout {
    %% DynamicText may be customized with overrides like below
    %% Currently given are the defaults
    
    %% Text which should be printed using `char-set:dynamics´ needs to be 
    %% wrapped into therefore reserved characters. Below the suggested default.
    \override DynamicText.details.separator-pair = #(cons #\{ #\})
    
    %% The subproperty `details.markup-commands´ determines which 
    %% markup-commands should be used:
    %% first value of the pair used to render dynamics, second for other text
    %% Below the suggested default.
    \override DynamicText.details.markup-commands =
    #(cons make-dynamic-markup make-italic-markup)
    %% Other coding-examples for `details.markup-commands´:

    %\override DynamicText.details.markup-commands =
    %  #(cons
    %    (lambda (arg) (make-normal-text-markup (make-box-markup arg)))
    %    make-underline-markup)
    
    %\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)))
    
    %% Dynamics and other texts may have different fontsize via an override
    %% for `details.dyn-rest-font-sizes´
    %% First value of the pair used to determine fontsize of dynamics, second
    %% for other text. 
    %% Unset per default, in this case the value from `DynamicText.font-size´ is
    %% taken.
    %% If set value from `DynamicText.font-size´ is added.
    %\override DynamicText.details.dyn-rest-font-sizes = #'(10 . -5)
    
    %% The space left and right from a dynamic is customizable:
    %% If the input-string contains something like "--{p}--", then the space 
    %% between left/right "--" and "p" is settable by `details.inner-x-space´
    %% Unset per default
    %\override DynamicText.details.inner-x-space = #'(0 . 0)
    
    %% Adds space around the whole dynamic text-part:
    %\override DynamicText.details.outer-x-space = #'(4 . 4)
    
    %% Both together work like:
    %% <outer-x-space>"--"<inner-x-space>"p"<inner-x-space>"--"<outer-x-space>
    %% Only here for conveniant viewing:
    \override DynamicText.after-line-breaking =
      #(lambda (grob)
        (ly:grob-set-property! grob 'stencil
          (box-stencil
            (ly:grob-property grob 'stencil)
            0
            0)))
  }
}
%}