input/regression/scheme-text-spanner.ly

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