1\version "2.19.21"
2
3\header {
4  texidoc = "Use @code{define-event-class}, scheme engraver methods,
5and grob creation methods to create a fully functional text spanner
6in 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
70start and stop.")
71         (types . (post-event 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 (eqv? 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 (eqv? axis X)
109             ly:side-position-interface::x-aligned-side
110             side-position-interface::y-aligned-side)
111         (axis-offset-symbol axis)))))
112
113schemeTextSpannerEngraver =
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
171schemeTextSpannerStart =
172#(make-span-event 'SchemeTextSpanEvent START)
173
174schemeTextSpannerEnd =
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 {
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}
197