\version "2.19.12"

\header {
  texidoc = "Use @code{define-event-class}, scheme engraver methods,
and grob creation methods to create a fully functional text spanner
in scheme."
}

#(define-event-class 'scheme-text-span-event 'span-event)

#(define (add-grob-definition grob-name grob-entry)
   (let* ((meta-entry   (assoc-get 'meta grob-entry))
          (class        (assoc-get 'class meta-entry))
          (ifaces-entry (assoc-get 'interfaces meta-entry)))
     (set-object-property! grob-name 'translation-type? ly:grob-properties?)
     (set-object-property! grob-name 'is-grob? #t)
     (set! ifaces-entry (append (case class
                                  ((Item) '(item-interface))
                                  ((Spanner) '(spanner-interface))
                                  ((Paper_column) '((item-interface
                                                     paper-column-interface)))
                                  ((System) '((system-interface
                                               spanner-interface)))
                                  (else '(unknown-interface)))
                          ifaces-entry))
     (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
     (set! ifaces-entry (cons 'grob-interface ifaces-entry))
     (set! meta-entry (assoc-set! meta-entry 'name grob-name))
     (set! meta-entry (assoc-set! meta-entry 'interfaces
                        ifaces-entry))
     (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
     (set! all-grob-descriptions
           (cons (cons grob-name grob-entry)
             all-grob-descriptions))))

#(add-grob-definition
  'SchemeTextSpanner
  `(
     (bound-details . ((left . ((Y . 0)
                                (padding . 0.25)
                                (attach-dir . ,LEFT)
                                ))
                       (left-broken . ((end-on-note . #t)))
                       (right . ((Y . 0)
                                 (padding . 0.25)
                                 ))
                       ))
     (dash-fraction . 0.2)
     (dash-period . 3.0)
     (direction . ,UP)
     (font-shape . italic)
     (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
     (outside-staff-priority . 350)
     (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
     (staff-padding . 0.8)
     (stencil . ,ly:line-spanner::print)
     (style . dashed-line)

     (meta . ((class . Spanner)
              (interfaces . (font-interface
                             line-interface
                             line-spanner-interface
                             outside-staff-interface
                             side-position-interface))))))

#(define scheme-event-spanner-types
   '(
      (SchemeTextSpanEvent
       . ((description . "Used to signal where scheme text spanner brackets
start and stop.")
          (types . (general-music scheme-text-span-event span-event event))
          ))
      ))

#(set!
  scheme-event-spanner-types
  (map (lambda (x)
         (set-object-property! (car x)
           'music-description
           (cdr (assq 'description (cdr x))))
         (let ((lst (cdr x)))
           (set! lst (assoc-set! lst 'name (car x)))
           (set! lst (assq-remove! lst 'description))
           (hashq-set! music-name-to-property-table (car x) lst)
           (cons (car x) lst)))
    scheme-event-spanner-types))

#(set! music-descriptions
       (append scheme-event-spanner-types music-descriptions))

#(set! music-descriptions
       (sort music-descriptions alist<?))

#(define (add-bound-item spanner item)
   (if (null? (ly:spanner-bound spanner LEFT))
       (ly:spanner-set-bound! spanner LEFT item)
       (ly:spanner-set-bound! spanner RIGHT item)))

#(define (axis-offset-symbol axis)
   (if (eq? axis X) 'X-offset 'Y-offset))

#(define (set-axis! grob axis)
   (if (not (number? (ly:grob-property grob 'side-axis)))
       (begin
        (set! (ly:grob-property grob 'side-axis) axis)
        (ly:grob-chain-callback
         grob
         (if (eq? axis X)
             ly:side-position-interface::x-aligned-side
             side-position-interface::y-aligned-side)
         (axis-offset-symbol axis)))))

schemeTextSpannerEngraver =
#(lambda (context)
   (let ((span '())
         (finished '())
         (event-start '())
         (event-stop '()))
     (make-engraver

      (listeners
       ((scheme-text-span-event engraver event)
        (if (= START (ly:event-property event 'span-direction))
            (set! event-start (cons event event-start))
            (set! event-stop (cons event event-stop)))))

      (acknowledgers
       ((note-column-interface engraver grob source-engraver)
        (for-each (lambda (s)
                    (ly:pointer-group-interface::add-grob
                     s 'note-columns grob)
                    (add-bound-item s grob))
          span)
        (for-each (lambda (f)
                    (ly:pointer-group-interface::add-grob
                     f 'note-columns grob)
                    (add-bound-item f grob))
          finished)))

      ((process-music trans)
       (for-each
        (lambda (es)
          (let ((es-id (ly:event-property es 'spanner-id)))
            (let loop ((sp span))
              (let ((sp-id (ly:event-property
                            (event-cause (car sp)) 'spanner-id)))
                (cond
                 ((null? sp) (ly:warning "No spanner to end!!"))
                 ((and
                   (string? sp-id)
                   (string? es-id)
                   (string=? sp-id es-id))
                  (set! finished (cons (car sp) finished))
                  (set! span (remove (lambda (s) (eq? s (car sp))) span)))
                 ((and
                   (null? sp-id)
                   (null? es-id))
                  (set! finished (cons (car sp) finished))
                  (set! span (remove (lambda (s) (eq? s (car sp))) span)))
                 (else (loop (cdr sp))))))))
        event-stop)

       (for-each
        (lambda (f)
          (ly:engraver-announce-end-grob trans f (event-cause f)))
        finished)

       (set! event-stop '())

       (for-each
        (lambda (es)
          (set! span
                (cons
                 (ly:engraver-make-grob trans 'SchemeTextSpanner es)
                 span))
          (set-axis! (car span) Y))
        event-start)

       (set! event-start '()))

      ((stop-translation-timestep trans)
       (for-each
        (lambda (s)
          (if (null? (ly:spanner-bound s LEFT))
              (ly:spanner-set-bound! s LEFT)
              (ly:context-property context 'currentMusicalColumn)))
        span)

       (for-each
        (lambda (f)
          (if (null? (ly:spanner-bound f RIGHT))
              (ly:spanner-set-bound! f RIGHT
                (ly:context-property context 'currentMusicalColumn))))
        finished)

       (set! finished '()))

      ((finalize trans)
       (for-each
        (lambda (f)
          (if (null? (ly:spanner-bound f RIGHT))
              (ly:spanner-set-bound! f RIGHT
                (ly:context-property context 'currentMusicalColumn))))
        finished)
       (set! finished '())
       (for-each
        (lambda (sp)
          (ly:warning "incomplete spanner removed!")
          (ly:grob-suicide! sp))
        span)
       (set! span '())))))

startTextSpan =
#(make-span-event 'SchemeTextSpanEvent START)

stopTextSpan =
#(make-span-event 'SchemeTextSpanEvent STOP)

startTextSpanOne =
#(make-music 'SchemeTextSpanEvent 'span-direction START 'spanner-id "1")

stopTextSpanOne =
#(make-music 'SchemeTextSpanEvent 'span-direction STOP 'spanner-id "1")

startTextSpanTwo =
#(make-music 'SchemeTextSpanEvent 'span-direction START 'spanner-id "2")

stopTextSpanTwo =
#(make-music 'SchemeTextSpanEvent 'span-direction STOP 'spanner-id "2")

startTextSpanThree =
#(make-music 'SchemeTextSpanEvent 'span-direction START 'spanner-id "3")

stopTextSpanThree =
#(make-music 'SchemeTextSpanEvent 'span-direction STOP 'spanner-id "3")

\layout {
  \context {
    \Global
    \grobdescriptions #all-grob-descriptions
  }
  \context {
    \Voice
    \consists \schemeTextSpannerEngraver
  }
}

\relative c' {
  \override SchemeTextSpanner.outside-staff-padding = 2
  a4 b
  \tweak SchemeTextSpanner.bound-details.left.text "rit."
  \tweak SchemeTextSpanner.bound-details.right.text \markup \upright { A tempo }
  \tweak SchemeTextSpanner.bound-details.left-broken.text ##f
  \tweak SchemeTextSpanner.bound-details.right-broken.text ##f
  \startTextSpanOne c d
  \tweak SchemeTextSpanner.bound-details.left.text "foo"
  \tweak SchemeTextSpanner.bound-details.right.text "bar"
  \tweak SchemeTextSpanner.bound-details.left-broken.text ##f
  \tweak SchemeTextSpanner.bound-details.right-broken.text ##f
  \startTextSpan
  a4 b c d\startTextSpanThree
  %\break %%ugh--order not preserved!
  a4 b c d\stopTextSpan
  a4 b
  \tweak SchemeTextSpanner.bound-details.left.text "foo"
  \tweak SchemeTextSpanner.bound-details.right.text "bar"
  \tweak SchemeTextSpanner.bound-details.left-broken.text ##f
  \tweak SchemeTextSpanner.bound-details.right-broken.text ##f
  \startTextSpan c d\stopTextSpanOne
  a4

  b c\stopTextSpanThree d\stopTextSpan
}