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