%% Example for creating multiple custom text spanners
%% Based on:
% http://lilypond.org/doc/v2.18/input/regression/collated-files.html
% look for:
% ‘scheme-text-spanner.ly’

\version "2.19.52"

#(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))))
                 
#(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 (eqv? 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 (eqv? axis X)
             ly:side-position-interface::x-aligned-side
             side-position-interface::y-aligned-side)
         (axis-offset-symbol axis)))))
         
#(define (namings names)
  (map
    (lambda (name)
      (list
        (string->symbol (format #f "~aTextSpanEvent" name))
        (ly:camel-case->lisp-identifier 
          (string->symbol (format #f "~aTextSpanEvent" name)))
        (string->symbol (format #f "~aTextSpanner" name))
        (string->symbol (format #f "~aTextSpannerEngraver" name))
        (string->symbol (string-downcase (format #f "~a-start" name)))
        (string->symbol (string-downcase (format #f "~a-stop" name)))))
    names))
    
#(define (scheme-event-spanner-types-proc lst)
  (map
    (lambda (x y)
      (cons
        x
        (list 
          '(description . "Used to signal where scheme text spanner brackets start and stop.")
           (cons 'types  
                 (list 'post-event 
                       y
                       'span-event 
                       'event)))))
    (map car (namings lst))
    (map second (namings lst))))
    
#(define spanner-props
  `(
    (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 define-engraver
  (lambda (engr-name g-name event-types)
    (module-define! (current-module) engr-name
      (lambda (context)
        (let ((span '())
              (finished '())
              (event-start '())
              (event-stop '()))
          `(
            (listeners 
              (,event-types
                .
                ,(lambda (engraver event)
                  (if (= START (ly:event-property event 'span-direction))
                      (set! event-start event)
                      (set! event-stop event)))))
            (acknowledgers 
              (note-column-interface 
              .
              ,(lambda (engraver grob source-engraver)
                (if (ly:spanner? span)
                    (begin
                      (ly:pointer-group-interface::add-grob span 'note-columns grob)
                      (add-bound-item span grob)))
                (if (ly:spanner? finished)
                    (begin
                      (ly:pointer-group-interface::add-grob finished 'note-columns grob)
                      (add-bound-item finished grob))))))
            (process-music 
              .
              ,(lambda (trans)
                 (if (ly:stream-event? event-stop)
                     (if (null? span)
                         (ly:warning "You're trying to end a scheme text spanner but you haven't started one.")
                         (begin 
                           (set! finished span)
                           (ly:engraver-announce-end-grob trans finished event-start)
                           (set! span '())
                           (set! event-stop '()))))
                 (if (ly:stream-event? event-start)
                     (begin 
                       (set! span (ly:engraver-make-grob trans g-name event-start))
                       (set-axis! span Y)
                       (set! event-start '())))))
            (stop-translation-timestep 
              .
              ,(lambda (trans)
                 (if (and (ly:spanner? span)
                          (null? (ly:spanner-bound span LEFT)))
                     (ly:spanner-set-bound! span LEFT
                       (ly:context-property context 'currentMusicalColumn)))
                 (if (ly:spanner? finished)
                     (begin
                       (if (null? (ly:spanner-bound finished RIGHT))
                           (ly:spanner-set-bound! finished RIGHT
                             (ly:context-property context 'currentMusicalColumn)))
                       (set! finished '())
                       (set! event-start '())
                       (set! event-stop '())))))
            (finalize 
              .
              ,(lambda (trans)
                 (if (ly:spanner? finished)
                     (begin
                       (if (null? (ly:spanner-bound finished RIGHT))
                           (ly:spanner-set-bound! finished RIGHT
                             (ly:context-property context 'currentMusicalColumn)))
                       (set! finished '())))
                 (if (ly:spanner? span)
                     (begin
                       (ly:warning "I think there's a dangling scheme text spanner :-)")
                       (ly:grob-suicide! span)
      	         (set! span '())))))))))))
%%%%%%%%%%%%%%%%%%%%%%%%%%

createSpannersAndEngravers =
#(define-void-function (name-list)(list?)
 (let ((naming-lst (namings name-list)))

  (for-each
    (lambda (text-span-event-name)
      (define-event-class text-span-event-name 'span-event))
    (map second naming-lst))
  
  (for-each
    (lambda (g-name) (add-grob-definition g-name spanner-props))
    (map third naming-lst))
  
  (let* ((new-scheme-event-spanner-types 
           (scheme-event-spanner-types-proc name-list))
         (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)))
                 new-scheme-event-spanner-types)))
  
    (set! music-descriptions
           (append scheme-event-spanner-types music-descriptions))
    
    (set! music-descriptions
           (sort music-descriptions alist<?)))
         
  ;; Create engravers
  (for-each 
    define-engraver
    (map fourth naming-lst)
    (map third naming-lst)
    (map second naming-lst))
        	
  ;; Create spanner-start/stop-commands
  ;; Example a-start/a-stop
  ;;
  ;; cmd-start: <spanner-name>-start
  ;; cmd-stop: <spanner-name>-stop
  ;; evt: <SpannerName>TextSpanEvent  
  (for-each
    (lambda (cmd-start cmd-stop evt)
      (module-define! (current-module) cmd-start
        (make-span-event evt START))
      (module-define! (current-module) cmd-stop
        (make-span-event evt STOP)))
    (map fifth naming-lst)
    (map sixth naming-lst)
    (map car naming-lst))

  (newline)
  (pretty-print 
  (cons
    "The following events (class and type), grobs, engravers and 
start/stop-commands are created"
    naming-lst))))