input/regression/scheme-text-spanner.ly

   1 \version "2.19.12"
   2
   3 \header {
   4   texidoc = "Use @code{define-event-class}, scheme engraver methods,
   5 and grob creation methods to create a fully functional text spanner
   6 in scheme."
   7 }
   8
   9 #(define-event-class 'scheme-text-span-event 'span-event)
  10
  11 #(define (add-grob-definition grob-name grob-entry)
  12    (let* ((meta-entry   (assoc-get 'meta grob-entry))
  13           (class        (assoc-get 'class meta-entry))
  14           (ifaces-entry (assoc-get 'interfaces meta-entry)))
  15      (set-object-property! grob-name 'translation-type? ly:grob-properties?)
  16      (set-object-property! grob-name 'is-grob? #t)
  17      (set! ifaces-entry (append (case class
  18                                   ((Item) '(item-interface))
  19                                   ((Spanner) '(spanner-interface))
  20                                   ((Paper_column) '((item-interface
  21                                                      paper-column-interface)))
  22                                   ((System) '((system-interface
  23                                                spanner-interface)))
  24                                   (else '(unknown-interface)))
  25                                 ifaces-entry))
  26      (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
  27      (set! ifaces-entry (cons 'grob-interface ifaces-entry))
  28      (set! meta-entry (assoc-set! meta-entry 'name grob-name))
  29      (set! meta-entry (assoc-set! meta-entry 'interfaces
  30                                   ifaces-entry))
  31      (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
  32      (set! all-grob-descriptions
  33            (cons (cons grob-name grob-entry)
  34                  all-grob-descriptions))))
  35
  36 #(add-grob-definition
  37   'SchemeTextSpanner
  38   `(
  39     (bound-details . ((left . ((Y . 0)
  40                                (padding . 0.25)
  41                                (attach-dir . ,LEFT)
  42                                ))
  43                       (left-broken . ((end-on-note . #t)))
  44                       (right . ((Y . 0)
  45                                 (padding . 0.25)
  46                                 ))
  47                       ))
  48     (dash-fraction . 0.2)
  49     (dash-period . 3.0)
  50     (direction . ,UP)
  51     (font-shape . italic)
  52     (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
  53     (outside-staff-priority . 350)
  54     (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
  55     (staff-padding . 0.8)
  56     (stencil . ,ly:line-spanner::print)
  57     (style . dashed-line)
  58
  59     (meta . ((class . Spanner)
  60              (interfaces . (font-interface
  61                             line-interface
  62                             line-spanner-interface
  63                             outside-staff-interface
  64                             side-position-interface))))))
  65
  66 #(define scheme-event-spanner-types
  67    '(
  68      (SchemeTextSpanEvent
  69       . ((description . "Used to signal where scheme text spanner brackets
  70 start and stop.")
  71          (types . (general-music scheme-text-span-event span-event event))
  72          ))
  73      ))
  74
  75 #(set!
  76   scheme-event-spanner-types
  77   (map (lambda (x)
  78          (set-object-property! (car x)
  79                                'music-description
  80                                (cdr (assq 'description (cdr x))))
  81          (let ((lst (cdr x)))
  82            (set! lst (assoc-set! lst 'name (car x)))
  83            (set! lst (assq-remove! lst 'description))
  84            (hashq-set! music-name-to-property-table (car x) lst)
  85            (cons (car x) lst)))
  86        scheme-event-spanner-types))
  87
  88 #(set! music-descriptions
  89        (append scheme-event-spanner-types music-descriptions))
  90
  91 #(set! music-descriptions
  92        (sort music-descriptions alist<?))
  93
  94 #(define (add-bound-item spanner item)
  95    (if (null? (ly:spanner-bound spanner LEFT))
  96        (ly:spanner-set-bound! spanner LEFT item)
  97        (ly:spanner-set-bound! spanner RIGHT item)))
  98
  99 #(define (axis-offset-symbol axis)
 100    (if (eq? axis X) 'X-offset 'Y-offset))
 101
 102 #(define (set-axis! grob axis)
 103   (if (not (number? (ly:grob-property grob 'side-axis)))
 104       (begin
 105         (set! (ly:grob-property grob 'side-axis) axis)
 106         (ly:grob-chain-callback
 107          grob
 108          (if (eq? axis X)
 109              ly:side-position-interface::x-aligned-side
 110              side-position-interface::y-aligned-side)
 111          (axis-offset-symbol axis)))))
 112
 113 schemeTextSpannerEngraver =
 114 #(lambda (context)
 115    (let ((span '())
 116          (finished '())
 117          (event-start '())
 118          (event-stop '()))
 119      (make-engraver
 120       (listeners ((scheme-text-span-event engraver event)
 121                   (if (= START (ly:event-property event 'span-direction))
 122                       (set! event-start event)
 123                       (set! event-stop event))))
 124       (acknowledgers ((note-column-interface engraver grob source-engraver)
 125                       (if (ly:spanner? span)
 126                           (begin
 127                             (ly:pointer-group-interface::add-grob span 'note-columns grob)
 128                             (add-bound-item span grob)))
 129                       (if (ly:spanner? finished)
 130                           (begin
 131                             (ly:pointer-group-interface::add-grob finished 'note-columns grob)
 132                             (add-bound-item finished grob)))))
 133       ((process-music trans)
 134        (if (ly:stream-event? event-stop)
 135            (if (null? span)
 136                (ly:warning "You're trying to end a scheme text spanner but you haven't started one.")
 137                (begin (set! finished span)
 138                       (ly:engraver-announce-end-grob trans finished event-start)
 139                       (set! span '())
 140                       (set! event-stop '()))))
 141        (if (ly:stream-event? event-start)
 142            (begin (set! span (ly:engraver-make-grob trans 'SchemeTextSpanner event-start))
 143                   (set-axis! span Y)
 144                   (set! event-start '()))))
 145       ((stop-translation-timestep trans)
 146        (if (and (ly:spanner? span)
 147                 (null? (ly:spanner-bound span LEFT)))
 148            (ly:spanner-set-bound! span LEFT
 149              (ly:context-property context 'currentMusicalColumn)))
 150        (if (ly:spanner? finished)
 151            (begin
 152              (if (null? (ly:spanner-bound finished RIGHT))
 153                  (ly:spanner-set-bound! finished RIGHT
 154                    (ly:context-property context 'currentMusicalColumn)))
 155              (set! finished '())
 156              (set! event-start '())
 157              (set! event-stop '()))))
 158       ((finalize trans)
 159        (if (ly:spanner? finished)
 160            (begin
 161              (if (null? (ly:spanner-bound finished RIGHT))
 162                  (ly:spanner-set-bound! finished RIGHT
 163                    (ly:context-property context 'currentMusicalColumn)))
 164              (set! finished '())))
 165        (if (ly:spanner? span)
 166            (begin
 167              (ly:warning "I think there's a dangling scheme text spanner :-(")
 168              (ly:grob-suicide! span)
 169              (set! span '())))))))
 170
 171 schemeTextSpannerStart =
 172 #(make-span-event 'SchemeTextSpanEvent START)
 173
 174 schemeTextSpannerEnd =
 175 #(make-span-event 'SchemeTextSpanEvent STOP)
 176
 177 \layout {
 178   \context {
 179     \Global
 180     \grobdescriptions #all-grob-descriptions
 181   }
 182   \context {
 183     \Voice
 184     \consists \schemeTextSpannerEngraver
 185   }
 186 }
 187
 188 \relative c' {
 189   a4 b\schemeTextSpannerStart c d |
 190   \repeat unfold 20 { a4 b c d | }
 191   a4 b c\schemeTextSpannerEnd d |
 192   \override SchemeTextSpanner.to-barline = ##t
 193   a4\schemeTextSpannerStart b d c |
 194   \repeat unfold 20 { a4 b c d | }
 195   a1\schemeTextSpannerEnd |
 196 }