1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
|
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2015 Ricardo Wurmus <rekado@elephly.net>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; LilyPond is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
(use-modules (srfi srfi-26))
;; settings
(define staff-padding-bass 2.5) ; Padding below bass staff
(define staff-padding-melody 4.5) ; Padding above melody staff
(define thickness 0.2) ; Thickness of note head outline
(define spread 1.5) ; Scaling factor for spreading
; string markers according to
; their fret position
(define (extract-property m)
"Extract finger or string number from music event."
(let ((name (ly:music-property m 'name)))
(cond
((eq? name 'FingeringEvent)
(cons 'finger
(ly:music-property m 'digit)))
((eq? name 'StringNumberEvent)
(cons 'string-number
(ly:music-property m 'string-number)))
(else #f))))
(define (replace-note-head! grob finger filled?)
"Replace note head in GROB with FINGER-dependent note head."
(define (first)
"Draw a circular note head."
(let* ((radius 0.45)
(out-radius (+ radius (/ thickness 2))))
(ly:make-stencil
(list 'circle 0.45 thickness filled?)
(cons (- out-radius) out-radius)
(cons (- out-radius) out-radius))))
(define (second)
"Draw a diamond-shaped note head."
(ly:make-stencil
`(polygon (list -0.5 0.0
0.0 0.5
0.5 0.0
0.0 -0.5)
,thickness ,filled?)
(cons -0.5 0.5)
(cons 0 0)))
(define (third)
"Draw a triangular note head."
;; adjust stem-attachment because downward facing stems are
;; broken otherwise
(ly:grob-set-property!
grob
'stem-attachment
(lambda (grob)
(let* ((stem (ly:grob-object grob 'stem))
(dir (ly:grob-property stem 'direction)))
(if (eq? UP dir)
'(1 . -0.5)
'(1 . 0.5)))))
(ly:make-stencil
`(polygon (list 0.0 0.4
0.45 -0.4
-0.45 -0.4)
,thickness ,filled?)
(cons -0.5 0.5)
(cons -1 1)))
(define (fourth)
"Draw a rectangular note head."
(let* ((width (- 1 thickness))
(edge (/ width 2))
(outer (+ edge (/ thickness 2))))
(ly:make-stencil
`(polygon (list ,edge ,edge
,edge ,(- edge)
,(- edge) ,(- edge)
,(- edge) ,edge)
,thickness ,filled?)
(cons (- outer) outer)
(cons (- outer) outer))))
;; select the correct note head and replace stencil
(let ((stencil (list-ref
(list first second third fourth)
(- finger 1))))
(ly:grob-set-property! grob 'stencil (stencil))))
(define-public (stafftab-engraver context)
"An engraver for StaffTab notation.
1. Listen for a music-event: collect pitch, note fill status,
finger, and string number for each encountered note and store them in
an alist in *props-list*.
2. Acknowledge note-head-interface: store all encountered note-head
grobs in the global list *grobs* so that they can be accessed in the
next stage
3. Process acknowledged: modify grobs dependent on the collected
properties. This includes replacing the note head, placing a string
marker, as well as adding an empty fret marker with a list of
accumulated fret positions to be displayed.
4. Stop translation timestep: compute sorted fret marker text from
previously collected fret positions.
5. Start next translation timestep: reset all lists for the next
iteration."
(let ((*grobs* '()) ; List of acknowleged grobs.
(*props-list* '()) ; Properties for each note at
; current timestep.
(*previous-props-list* '()) ; Copy of *props-list* for
; previous timestep.
(*adjust-later*
'((fret-grob . #f) ; Shared grob for fret numbers.
(properties . ()))) ; List of note properties needed
; at the end of the timestep for
; graphical adjustments.
;; The tuning of this context (bass or melody side)
(tuning (reverse
(ly:context-property context 'stringTunings))))
(define (fret pitch string-number)
"Return fret number on the string STRING-NUMBER given PITCH."
(let* ((string (remainder (- string-number 1)
(length tuning)))
(root (list-ref tuning string))
(root-semi (ly:pitch-semitones root))
(pitch-semi (ly:pitch-semitones pitch)))
(- pitch-semi root-semi)))
(define (make-fret-marker trans string-number)
"Create and initialize a grob for fret position annotations in
translation context TRANS. When STRING-NUMBER is greater than the
number of strings in this string group, it relates to bass strings and
thus has to be placed in the other direction."
(let* ((grob (ly:engraver-make-grob trans 'TextScript '()))
(bass? (> string-number (length tuning)))
(dir (if bass? DOWN UP))
(pad (if bass?
staff-padding-bass
staff-padding-melody)))
(for-each (lambda (pair)
(ly:grob-set-property! grob (car pair) (cdr pair)))
`((color . ,(x11-color 'DimGray))
(font-size . -5)
(side-axis . 0) ;centre align
(self-alignment-X . 0) ;centre align
(direction . ,dir)
(staff-padding . ,pad)))
grob))
(define (make-string-marker trans string-number)
"Add string marker for STRING-NUMBER in translation context
TRANS."
(let* ((grob (ly:engraver-make-grob trans 'StringNumber '()))
(strings (length tuning))
(bass? (> string-number strings))
(marker (ly:make-stencil
(list 'embedded-ps
"gsave
currentpoint translate
newpath
0 setlinecap
0.05 setlinewidth
-1.2 0.2 moveto
1.2 0.2 lineto
1.2 -0.1 lineto
-1.2 -0.1 lineto
-1.2 0.2 lineto
stroke
grestore")
(cons -1.3 1.3)
(cons -0.1 0.2))))
;; centre-align
(ly:grob-set-property! grob 'side-axis 0)
;; replace stencil
(ly:grob-set-property! grob 'stencil marker)
;; move marker to staff line
;; - default placement on melody side equals to string 3
;; - default placement on bass side equals to third bass string
;; (9 on a Grand, 8 on a 10-string)
(ly:grob-set-property! grob 'Y-offset
(- (+ 3 (if bass? strings 0))
string-number))
grob))
(define (add-properties! new? alist)
"Add a property list ALIST to the current object in
*props-list*. If NEW? is true, the properties are added to a new
object."
(set! *props-list*
(if new?
(cons alist *props-list*)
(if (null? *props-list*)
(list alist)
(let ((current (car *props-list*)))
(cons (append alist current)
(cdr *props-list*)))))))
(define (process-note! trans total index grob props)
"Render a note in the translator context TRANS given an
acknowledged GROB, a property list PROPS and an INDEX to look up the
matching previous note in a chord of TOTAL notes."
(let* ((prev (if (> (length *previous-props-list*) index)
(list-ref *previous-props-list* index)
#f))
(filled? (assoc-ref props 'filled?))
(pitch (assoc-ref props 'pitch))
(finger (or (assoc-ref props 'finger)
(and prev (assoc-ref prev 'finger)) 1))
(string-number (or (assoc-ref props 'string-number)
(and prev (assoc-ref
prev 'string-number)))))
(replace-note-head! grob finger filled?)
(if string-number
(let ((fret-no (fret pitch string-number))
(string-marker (make-string-marker trans
string-number)))
(if (> fret-no 0)
(begin
;; If this is the first note in this timestep to
;; need fret annotations, initialise the shared
;; fret-marker first.
(if (not (assoc-ref *adjust-later* 'fret-grob))
(assoc-set! *adjust-later* 'fret-grob
(make-fret-marker trans string-number)))
;; Record fret position + string number + string
;; marker for later adjustment
(assoc-set! *adjust-later* 'properties
(cons (list fret-no
string-number
string-marker)
(assoc-ref *adjust-later*
'properties)))))))))
(make-engraver
(listeners
((music-event trans event)
(let* ((m (ly:event-property event 'music-cause))
(name (ly:music-property m 'name)))
(if (eq? name 'NoteEvent)
;; create a new object to collect data
;; whenever a note-event is encountered
(add-properties!
'as-new-note
(append
(list
(cons 'pitch
(ly:event-property event 'pitch))
(cons 'filled?
(ly:moment<? (ly:music-duration-length m)
(ly:make-moment 1 2))))
;; if this event has articulations, get the finger
;; and string number from the inner music object
(delq #f
(map extract-property
(ly:music-property m 'articulations)))))
;; otherwise add properties to existing object
(let ((prop (extract-property m)))
(if prop (add-properties! #f (list prop))))))))
(acknowledgers
((note-head-interface trans grob source)
(set! *grobs* (cons grob *grobs*))))
((process-acknowledged trans)
(if (and (not (null? *grobs*))
(= (length *grobs*)
(length *props-list*)))
(begin
(for-each (cute process-note!
trans (length *props-list*) <...>)
(iota (length *props-list*))
*grobs*
*props-list*)
;; clear grobs now or we will never get past this step
(set! *grobs* '()))))
;; Reset all state at the beginning of the timestep
((start-translation-timestep trans)
(set! *previous-props-list* *props-list*)
(set! *props-list* '())
(set! *adjust-later* (list (cons 'fret-grob #f)
(cons 'properties '()))))
;; Perform final graphical adjustments
((stop-translation-timestep trans)
(let ((fret-grob (assoc-ref *adjust-later* 'fret-grob))
(props (assoc-ref *adjust-later* 'properties)))
;; Display fret numbers in string order.
(if fret-grob
(let* (;; sort on string number (cadr of each pair)
(sorted (sort props (lambda (a b)
(< (cadr a) (cadr b)))))
;; join all fret numbers with a dot
(text (string-join (map (lambda (p)
(number->string (car p)))
sorted) ".")))
;; update text
(ly:grob-set-property! fret-grob 'text text)))
;; Adjust the string markers for chords
;; - those with lower fret number should be pushed left
;; - those with higher fret number should be pushed right
(let ((frets (map car props)))
(if (> (length frets) 1)
(let* ((low (apply min frets))
(high (apply max frets))
(range (- high low)))
(if (not (zero? range))
(for-each
(lambda (p)
(let* ((string-marker (caddr p))
(fret-no (car p))
(offset (/ (- fret-no low (/ range 2))
range)))
(ly:grob-set-property! string-marker
'X-offset
(* spread offset))))
props))))))))))
|
