input/regression/scheme-text-spanner.ly

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