| blob | d402b7cf249a5b445f27d9166cdb16f9d1ebcba1 |
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2010--2011 Mike Solomon <mikesol@stanfordalumni.org>
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/>.
18 ;; Constants
20 (define CENTRAL-COLUMN-HOLE-PLACEMENTS '((one . (0.0 . 6.5))
21 (two . (0.0 . 5.5))
22 (three . (0.0 . 4.5))
23 (four . (0.0 . 3.0))
24 (five . (0.0 . 2.0))
25 (six . (0.0 . 1.0))))
27 (define CENTRAL-COLUMN-HOLE-LIST (map car CENTRAL-COLUMN-HOLE-PLACEMENTS))
28 (define CENTRAL-COLUMN-HOLE-H-LIST (cons 'h CENTRAL-COLUMN-HOLE-LIST))
30 ;; Utility functions
32 (define (return-1 x) 1.0)
34 (define (make-spreadsheet parameter-list)
35 "Makes a spreadsheet function with columns of parameter-list.
36 This function can then be filled with rows.
37 For example:
38 @code{guile> ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6)))}
39 @code{(((foo . 1) (bar . 2)) ((foo . 3) (bar . 4)) ((foo . 5) (bar . 6)))}"
40 (lambda (ls)
41 (map (lambda (list-to-translate)
42 (map (lambda (name element)
43 `(,name . ,element))
44 parameter-list
45 list-to-translate))
46 ls)))
48 (define (get-spreadsheet-column column spreadsheet)
49 "Gets all the values in @code{column} form @code{spreadsheet}
50 made by @{make-spreadsheet}.
51 For example:
52 @code{guile> (get-spreadsheet-column 'bar ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6))))}
53 @code{(2 4 6)}"
54 (map (lambda (row) (assoc-get column row)) spreadsheet))
56 (define (make-named-spreadsheet parameter-list)
57 "Makes a named spreadsheet function with columns of parameter-list.
58 This function can then be filled with named rows
59 For example:
60 @code{guile> ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6))))}
61 @code{((x (foo . 1) (bar . 2)) (y (foo . 3) (bar . 4)) (z (foo . 5) (bar . 6)))}"
62 (lambda (ls)
63 (map (lambda (list-to-translate)
64 `(,(list-ref list-to-translate 0)
65 . ,(map (lambda (name element)
66 `(,name . ,element))
67 parameter-list
68 (list-tail list-to-translate 1))))
69 ls)))
71 (define (get-named-spreadsheet-column column spreadsheet)
72 "Gets all the values in @code{column} form @code{spreadsheet}
73 made by @{make-named-spreadsheet}.
74 For example:
75 @code{guile> (get-spreadsheet-column 'bar ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6)))))}
76 @code{((x . 2) (y . 4) (z . 6))}"
77 (map
78 (lambda (row) (cons (car row) (assoc-get column (cdr row))))
79 spreadsheet))
81 (define make-key-alist
82 (make-named-spreadsheet '(name offset graphical textual)))
84 (define (simple-stencil-alist stencil offset)
85 "A stencil alist that contains one and only one stencil.
86 Shorthand used repeatedly in various instruments."
87 `((stencils . (,stencil))
88 (offset . ,offset)
89 (textual? . #f)
90 (xy-scale-function . (,return-1 . ,return-1))))
92 (define (make-central-column-hole-addresses keys)
93 "Takes @code{keys} and ascribes them to the central column."
94 (map
95 (lambda (key) `(central-column . ,key))
96 keys))
98 (define (make-key-symbols hand)
99 "Takes @code{hand} and ascribes @code{key} to it."
100 (lambda (keys)
101 (map (lambda (key) `(,hand . ,key))
102 keys)))
104 (define make-left-hand-key-addresses (make-key-symbols 'left-hand))
106 (define make-right-hand-key-addresses (make-key-symbols 'right-hand))
108 ;; Flute assembly instructions
110 (define flute-change-points
111 ((make-named-spreadsheet '(piccolo flute flute-b-extension))
112 `((bottom-group-key-names
113 . (((x
114 . ((offset . (-0.45 . -1.05))
115 (stencil . ,piccolo-rh-x-key-stencil)
116 (text? . ("X" . #f))
117 (complexity . trill))))
118 ((cis
119 . ((offset . (0.0 . 0.0))
120 (stencil . ,flute-rh-cis-key-stencil)
121 (text? . ("C" . 1))
122 (complexity . trill)))
123 (c
124 . ((offset . (0.3 . 0.0))
125 (stencil . ,flute-rh-c-key-stencil)
126 (text? . ("C" . #f))
127 (complexity . trill)))
128 (gz
129 . ((offset . (0.0 . -1.2))
130 (stencil . ,flute-rh-gz-key-stencil)
131 (text? . ("gz" . #f))
132 (complexity . trill))))
133 ((cis
134 . ((offset . (0.0 . 0.0))
135 (stencil . ,flute-rh-cis-key-stencil)
136 (text? . ("C" . 1))
137 (complexity . trill)))
138 (c
139 . ((offset . (0.3 . 0.0))
140 (stencil . ,flute-rh-c-key-stencil)
141 (text? . ("C" . #f))
142 (complexity . trill)))
143 (b
144 . ((offset . (1.0 . 0.0))
145 (stencil . ,flute-rh-b-key-stencil)
146 (text? . ("B" . #f))
147 (complexity . trill)))
148 (gz
149 . ((offset . (0.0 . -1.2))
150 (stencil . ,flute-rh-gz-key-stencil)
151 (text? . ("gz" . #f))
152 (complexity . trill))))))
153 (bottom-group-graphical-stencil
154 . (((right-hand . ees) (right-hand . x))
155 ,(make-right-hand-key-addresses '(ees cis c gz))
156 ,(make-right-hand-key-addresses '(ees cis c b gz))))
157 (bottom-group-graphical-draw-instruction
158 . (((right-hand . ees))
159 ,(make-right-hand-key-addresses '(ees cis c))
160 ,(make-right-hand-key-addresses '(ees cis c b))))
161 (bottom-group-special-key-instruction
162 . ((,rich-group-draw-rule ((right-hand . x)) ((right-hand . ees)))
163 (,rich-group-draw-rule ((right-hand . gz))
164 ,(make-right-hand-key-addresses
165 '(ees cis c)))
166 (,rich-group-draw-rule ((right-hand . gz))
167 ,(make-right-hand-key-addresses
168 '(ees cis c b)))))
169 (bottom-group-text-stencil
170 . (,(make-right-hand-key-addresses '(bes d dis ees x))
171 ,(make-right-hand-key-addresses '(bes d dis ees cis c gz))
172 ,(make-right-hand-key-addresses '(bes d dis ees cis c b gz)))))))
174 (define (generate-flute-family-entry flute-name)
175 (let*
176 ((change-points
177 (get-named-spreadsheet-column
178 flute-name
179 flute-change-points)))
180 `(,flute-name
181 . ((keys
182 . ((hidden
183 . ((midline
184 . ((offset . (0.0 . 0.0))
185 (stencil . ,midline-stencil)
186 (text? . #f)
187 (complexity . basic)))))
188 (central-column
189 . ((one
190 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
191 (stencil . ,ring-column-circle-stencil)
192 (text? . #f)
193 (complexity . ring)))
194 (two
195 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
196 (stencil . ,ring-column-circle-stencil)
197 (text? . #f)
198 (complexity . ring)))
199 (three
200 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
201 (stencil . ,ring-column-circle-stencil)
202 (text? . #f)
203 (complexity . ring)))
204 (four
205 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
206 (stencil . ,ring-column-circle-stencil)
207 (text? . #f)
208 (complexity . ring)))
209 (five
210 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
211 (stencil . ,ring-column-circle-stencil)
212 (text? . #f)
213 (complexity . ring)))
214 (six
215 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
216 (stencil . ,ring-column-circle-stencil)
217 (text? . #f)
218 (complexity . ring)))))
219 (left-hand
220 . ((bes
221 . ((offset . (0.5 . 1.8))
222 (stencil . ,flute-lh-bes-key-stencil)
223 (text? . ("B" . 0))
224 (complexity . trill)))
225 (b
226 . ((offset . (0.0 . 0.0))
227 (stencil . ,flute-lh-b-key-stencil)
228 (text? . ("B" . #f))
229 (complexity . trill)))
230 (gis
231 . ((offset . (0.0 . 0.0))
232 (stencil . ,flute-lh-gis-key-stencil)
233 (text? . ("G" . 1))
234 (complexity . trill)))))
235 (right-hand
236 . ,(append `((bes
237 . ((offset . (0.0 . 0.0))
238 (stencil . ,flute-rh-bes-key-stencil)
239 (text? . ("B" . 0))
240 (complexity . trill)))
241 (d
242 . ((offset . (0.0 . 0.0))
243 (stencil . ,flute-rh-d-key-stencil)
244 (text? . ("D" . #f))
245 (complexity . trill)))
246 (dis
247 . ((offset . (0.0 . 0.0))
248 (stencil . ,flute-rh-dis-key-stencil)
249 (text? . ("D" . 1))
250 (complexity . trill)))
251 (ees
252 . ((offset . (1.5 . 1.3))
253 (stencil . ,flute-rh-ees-key-stencil)
254 (text? . ("E" . 0))
255 (complexity . trill))))
256 (assoc-get 'bottom-group-key-names change-points)))))
257 (graphical-commands
258 . ((stencil-alist
259 . ((stencils
260 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
261 ((stencils
262 . ,(make-central-column-hole-addresses
263 CENTRAL-COLUMN-HOLE-LIST))
264 (xy-scale-function . (,identity . ,identity))
265 (textual? . #f)
266 (offset . (0.0 . 0.0)))
267 ((stencils . ((left-hand . bes) (left-hand . b)))
268 (xy-scale-function . (,return-1 . ,return-1))
269 (textual? . #f)
270 (offset . (-1.5 . 6.5)))
271 ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0))
272 ,(simple-stencil-alist '(right-hand . bes) '(-1.75 . 3.05))
273 ,(simple-stencil-alist '(right-hand . d) '(-1.0 . 2.5))
274 ,(simple-stencil-alist '(right-hand . dis) '(-1.0 . 1.5))
275 ((stencils
276 . ,(assoc-get 'bottom-group-graphical-stencil
277 change-points))
278 (xy-scale-function . (,return-1 . ,return-1))
279 (textual? . #f)
280 (offset . (0.0 . -0.6)))))
281 (xy-scale-function . (,identity . ,identity))
282 (textual? . #f)
283 (offset . (0.0 . 0.0))))
284 (draw-instructions
285 . ((,apply-group-draw-rule-series
286 (((left-hand . bes) (left-hand . b))
287 ,(assoc-get 'bottom-group-graphical-draw-instruction
288 change-points)))
289 ,(assoc-get 'bottom-group-special-key-instruction
290 change-points)
291 (,group-automate-rule
292 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
293 (,group-automate-rule ((hidden . midline)))))
294 (extra-offset-instructions
295 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
296 (text-commands
297 . ((stencil-alist
298 . ((stencils
299 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
300 ((stencils
301 . ,(make-central-column-hole-addresses
302 CENTRAL-COLUMN-HOLE-LIST))
303 (xy-scale-function . (,identity . ,identity))
304 (textual? . #f)
305 (offset . (0.0 . 0.0)))
306 ((stencils . ,(make-left-hand-key-addresses '(bes b gis)))
307 (textual? . ,lh-woodwind-text-stencil)
308 (offset . (1.5 . 3.75)))
309 ((stencils . ,(assoc-get 'bottom-group-text-stencil
310 change-points))
311 (textual? . ,rh-woodwind-text-stencil)
312 (offset . (-1.25 . 0.0)))))
313 (xy-scale-function . (,identity . ,identity))
314 (textual? . #f)
315 (offset . (0.0 . 0.0))))
316 (draw-instructions
317 . ((,apply-group-draw-rule-series
318 (,(make-left-hand-key-addresses '(bes b gis))
319 ,(assoc-get 'bottom-group-text-stencil change-points)))
320 (,group-automate-rule
321 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
322 (,group-automate-rule ((hidden . midline)))))
323 (extra-offset-instructions
324 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
326 ;;; Tin whistle assembly instructions
328 (define tin-whistle-change-points
329 ((make-named-spreadsheet '(tin-whistle)) '()))
331 (define (generate-tin-whistle-family-entry tin-whistle-name)
332 (let*
333 ((change-points
334 (get-named-spreadsheet-column tin-whistle-name tin-whistle-change-points)))
335 `(,tin-whistle-name
336 . ((keys
337 . ((hidden
338 . ((midline
339 . ((offset . (0.0 . 0.0))
340 (stencil . ,midline-stencil)
341 (text? . #f)
342 (complexity . basic)))))
343 (central-column
344 . ((one
345 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
346 (stencil . ,column-circle-stencil)
347 (text? . #f)
348 (complexity . covered)))
349 (two
350 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
351 (stencil . ,column-circle-stencil)
352 (text? . #f)
353 (complexity . covered)))
354 (three
355 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
356 (stencil . ,column-circle-stencil)
357 (text? . #f)
358 (complexity . covered)))
359 (four
360 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
361 (stencil . ,column-circle-stencil)
362 (text? . #f)
363 (complexity . covered)))
364 (five
365 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
366 (stencil . ,column-circle-stencil)
367 (text? . #f)
368 (complexity . covered)))
369 (six
370 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
371 (stencil . ,column-circle-stencil)
372 (text? . #f)
373 (complexity . covered)))))
374 (left-hand . ())
375 (right-hand . ())))
376 (graphical-commands
377 . ((stencil-alist
378 . ((stencils
379 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
380 ((stencils
381 . ,(make-central-column-hole-addresses
382 CENTRAL-COLUMN-HOLE-LIST))
383 (xy-scale-function . (,identity . ,identity))
384 (textual? . #f)
385 (offset . (0.0 . 0.0)))))
386 (xy-scale-function . (,identity . ,identity))
387 (textual? . #f)
388 (offset . (0.0 . 0.0))))
389 (draw-instructions
390 . ((,group-automate-rule
391 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
392 (,group-automate-rule ((hidden . midline)))))
393 (extra-offset-instructions
394 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
395 (text-commands
396 . ((stencil-alist
397 . ((stencils .
398 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
399 ((stencils
400 . ,(make-central-column-hole-addresses
401 CENTRAL-COLUMN-HOLE-H-LIST))
402 (xy-scale-function . (,identity . ,identity))
403 (textual? . #f)
404 (offset . (0.0 . 0.0)))))
405 (xy-scale-function . (,identity . ,identity))
406 (textual? . #f)
407 (offset . (0.0 . 0.0))))
408 (draw-instructions
409 . ((,group-automate-rule
410 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
411 (,group-automate-rule ((hidden . midline)))))
412 (extra-offset-instructions
413 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
415 ;;; Oboe assembly instructions
417 (define oboe-change-points
418 ((make-named-spreadsheet '(oboe)) '()))
420 (define (generate-oboe-family-entry oboe-name)
421 (let*
422 ((change-points
423 (get-named-spreadsheet-column oboe-name oboe-change-points)))
424 `(,oboe-name
425 . ((keys
426 . ((hidden
427 . ((midline
428 . ((offset . (0.0 . 0.0))
429 (stencil . ,midline-stencil)
430 (text? . #f)
431 (complexity . basic)))))
432 (central-column
433 . ((one
434 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
435 (stencil . ,ring-column-circle-stencil)
436 (text? . #f)
437 (complexity . ring)))
438 (two
439 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
440 (stencil . ,ring-column-circle-stencil)
441 (text? . #f)
442 (complexity . ring)))
443 (three
444 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
445 (stencil . ,ring-column-circle-stencil)
446 (text? . #f)
447 (complexity . ring)))
448 (four
449 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
450 (stencil . ,ring-column-circle-stencil)
451 (text? . #f)
452 (complexity . ring)))
453 (five
454 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
455 (stencil . ,ring-column-circle-stencil)
456 (text? . #f)
457 (complexity . ring)))
458 (six
459 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
460 (stencil . ,ring-column-circle-stencil)
461 (text? . #f)
462 (complexity . ring)))
463 (h
464 . ((offset . (0.0 . 6.25))
465 (stencil . ,(variable-column-circle-stencil 0.4))
466 (text? . #f)
467 (complexity . trill)))))
468 (left-hand
469 . ((I
470 . ((offset . (0.0 . 0.0))
471 (stencil . ,oboe-lh-I-key-stencil)
472 (text? . ("I" . #f))
473 (complexity . trill)))
474 (III
475 . ((offset . (0.0 . 2.6))
476 (stencil . ,oboe-lh-III-key-stencil)
477 (text? . ("III" . #f))
478 (complexity . trill)))
479 (II
480 . ((offset . (0.0 . 0.0))
481 (stencil . ,oboe-lh-II-key-stencil)
482 (text? . ("II" . #f))
483 (complexity . trill)))
484 (b
485 . ((offset . (0.0 . 0.0))
486 (stencil . ,oboe-lh-b-key-stencil)
487 (text? . ("B" . #f))
488 (complexity . trill)))
489 (d
490 . ((offset . (0.0 . 0.0))
491 (stencil . ,oboe-lh-d-key-stencil)
492 (text? . ("D" . #f))
493 (complexity . trill)))
494 (cis
495 . ((offset . (0.0 . 0.0))
496 (stencil . ,oboe-lh-cis-key-stencil)
497 (text? . ("C" . 1))
498 (complexity . trill)))
499 (gis
500 . ((offset . (-0.85 . 0.2))
501 (stencil . ,oboe-lh-gis-key-stencil)
502 (text? . ("G" . 1))
503 (complexity . trill)))
504 (ees
505 . ((offset . (2.05 . -3.65))
506 (stencil . ,oboe-lh-ees-key-stencil)
507 (text? . ("E" . 0))
508 (complexity . trill)))
509 (low-b
510 . ((offset . (3.6 . 0.5))
511 (stencil . ,oboe-lh-low-b-key-stencil)
512 (text? . ("b" . #f))
513 (complexity . trill)))
514 (bes
515 . ((offset . (2.25 . -4.15))
516 (stencil . ,oboe-lh-bes-key-stencil)
517 (text? . ("B" . 0))
518 (complexity . trill)))
519 (f
520 . ((offset . (2.15 . -3.85))
521 (stencil . ,oboe-lh-f-key-stencil)
522 (text? . ("F" . #f))
523 (complexity . trill)))))
524 (right-hand
525 . ((a
526 . ((offset . (1.5 . 1.2))
527 (stencil . ,oboe-rh-a-key-stencil)
528 (text? . ("A" . #f))
529 (complexity . trill)))
530 (gis
531 . ((offset . (0.0 . 0.0))
532 (stencil . ,oboe-rh-gis-key-stencil)
533 (text? . ("G" . 1))
534 (complexity . trill)))
535 (d
536 . ((offset . (0.0 . 0.0))
537 (stencil . ,oboe-rh-d-key-stencil)
538 (text? . ("D" . #f))
539 (complexity . trill)))
540 (f
541 . ((offset . (0.0 . 0.0))
542 (stencil . ,oboe-rh-f-key-stencil)
543 (text? . ("F" . #f))
544 (complexity . trill)))
545 (banana
546 . ((offset . (0.0 . 0.0))
547 (stencil . ,oboe-rh-banana-key-stencil)
548 (text? . ("ban" . #f))
549 (complexity . trill)))
550 (c
551 . ((offset . (0.0 . 0.0))
552 (stencil . ,oboe-rh-c-key-stencil)
553 (text? . ("C" . #f))
554 (complexity . trill)))
555 (cis
556 . ((offset . (3.8 . -0.6))
557 (stencil . ,oboe-rh-cis-key-stencil)
558 (text? . ("C" . 1))
559 (complexity . trill)))
560 (ees
561 . ((offset . (0.0 . -1.8))
562 (stencil . ,oboe-rh-ees-key-stencil)
563 (text? . ("E" . 0))
564 (complexity . trill)))))))
565 (graphical-commands
566 . ((stencil-alist
567 . ((stencils
568 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
569 ((stencils
570 . ,(make-central-column-hole-addresses
571 CENTRAL-COLUMN-HOLE-H-LIST))
572 (xy-scale-function . (,identity . ,identity))
573 (textual? . #f)
574 (offset . (0.0 . 0.0)))
575 ((stencils . ((left-hand . I) (left-hand . III)))
576 (xy-scale-function . (,return-1 . ,return-1))
577 (textual? . #f)
578 (offset . (-2.5 . 6.5)))
579 ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0))
580 ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0))
581 ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0))
582 ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0))
583 ((stencils
584 . ,(make-left-hand-key-addresses '(gis bes low-b ees f)))
585 (xy-scale-function . (,return-1 . ,return-1))
586 (textual? . #f)
587 (offset . (0.0 . 3.9)))
588 ((stencils .
589 ,(make-right-hand-key-addresses '(a gis)))
590 (xy-scale-function . (,return-1 . ,return-1))
591 (textual? . #f)
592 (offset . (-3.5 . 3.5)))
593 ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5))
594 ,(simple-stencil-alist '(right-hand . f) '(-1.0 . 1.5))
595 ,(simple-stencil-alist '(right-hand . banana) '(1.7 . 1.0))
596 ((stencils . ,(make-right-hand-key-addresses '(c cis ees)))
597 (xy-scale-function . (,return-1 . ,return-1))
598 (textual? . #f)
599 (offset . (-3.4 . 0.3)))))
600 (xy-scale-function . (,identity . ,identity))
601 (textual? . #f)
602 (offset . (0.0 . 0.0))))
603 (draw-instructions
604 . ((,apply-group-draw-rule-series
605 (((right-hand . a) (right-hand . gis))
606 ,(make-left-hand-key-addresses '(gis bes low-b ees))
607 ,(make-right-hand-key-addresses '(cis c ees))))
608 (,rich-group-draw-rule
609 ((left-hand . III))
610 ((left-hand . I)))
611 (,rich-group-draw-rule
612 ((left-hand . f))
613 ,(make-left-hand-key-addresses '(gis bes low-b ees)))
614 (,group-automate-rule
615 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
616 (,group-automate-rule ((hidden . midline)))))
617 (extra-offset-instructions
618 . ((,rich-group-extra-offset-rule
619 ((central-column . h)) ((central-column . one)) (0.0 . 0.8))
620 (,uniform-extra-offset-rule (0.0 . 0.0))))))
621 (text-commands
622 . ((stencil-alist
623 . ((stencils .
624 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
625 ((stencils
626 . ,(make-central-column-hole-addresses
627 CENTRAL-COLUMN-HOLE-H-LIST))
628 (xy-scale-function . (,identity . ,identity))
629 (textual? . #f)
630 (offset . (0.0 . 0.0)))
631 ((stencils . ,(make-left-hand-key-addresses '(III I)))
632 (textual? . ,lh-woodwind-text-stencil)
633 (offset . (-2.8 . 7.0)))
634 ((stencils . ,(make-left-hand-key-addresses '(II)))
635 (textual? . ,lh-woodwind-text-stencil)
636 (offset . (2.2 . 7.0)))
637 ((stencils
638 . ,(make-left-hand-key-addresses
639 '(b d cis gis ees low-b bes f)))
640 (textual? . ,lh-woodwind-text-stencil)
641 (offset . (1.5 . 3.75)))
642 ((stencils
643 . ,(make-right-hand-key-addresses
644 '(a gis d f banana c cis ees)))
645 (textual? . ,rh-woodwind-text-stencil)
646 (offset . (-1.25 . 0.0)))))
647 (xy-scale-function . (,identity . ,identity))
648 (textual? . #f)
649 (offset . (0.0 . 0.0))))
650 (draw-instructions
651 . ((,apply-group-draw-rule-series
652 (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f))
653 ,(make-left-hand-key-addresses '(III I))
654 ,(make-right-hand-key-addresses '(a gis d f banana c cis ees))))
655 (,group-automate-rule
656 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
657 (,group-automate-rule ((hidden . midline)))))
658 (extra-offset-instructions
659 . ((,rich-group-extra-offset-rule
660 ((central-column . h))
661 ((central-column . one))
662 (0.0 . 0.8))
663 (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
665 ;; Clarinet assembly instructions
667 (define clarinet-change-points
668 ((make-named-spreadsheet '(clarinet bass-clarinet low-bass-clarinet))
669 `((bottom-group-key-names
670 . (()
671 ((f
672 . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
673 (stencil . ,bass-clarinet-rh-f-key-stencil)
674 (text? . ("F" . #f))
675 (complexity . trill))))
676 ((f
677 . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
678 (stencil . ,low-bass-clarinet-rh-f-key-stencil)
679 (text? . ("F" . #f))
680 (complexity . trill)))
681 (d
682 . ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* -1 (+ 0.75 CL-RH-HAIR))))
683 (stencil . ,clarinet-rh-d-key-stencil)
684 (text? . ("d" . #f))
685 (complexity . trill)))
686 (low-cis
687 . ((offset . (0.0 . 1.4))
688 (stencil . ,clarinet-rh-low-cis-key-stencil)
689 (text? . ("c" . 1))
690 (complexity . trill)))
691 (low-d
692 . ((offset . (0.0 . 2.4))
693 (stencil . ,clarinet-rh-low-d-key-stencil)
694 (text? . ("d" . #f))
695 (complexity . trill)))
696 (low-c
697 . ((offset . (0.0 . 0.0))
698 (stencil . ,clarinet-rh-low-c-key-stencil)
699 (text? . ("c" . #f))
700 (complexity . trill))))))
701 (left-extra-key-names
702 . (()
703 ()
704 ((d
705 . ((offset . (4.0 . -0.8))
706 (stencil . ,clarinet-lh-d-key-stencil)
707 (text? . ("D" . #f))
708 (complexity . trill))))))
709 (right-thumb-group
710 . (()
711 ()
712 (((stencils
713 . ,(make-right-hand-key-addresses '(low-c low-cis)))
714 (xy-scale-function . (,return-1 . ,return-1))
715 (textual? . #f)
716 (offset . (-1.3 . 4.0))))))
717 (low-left-hand-key-addresses
718 . (,(make-left-hand-key-addresses '(cis f e fis))
719 ,(make-left-hand-key-addresses '(cis f e fis))
720 ,(make-left-hand-key-addresses '(cis f e fis d))))
721 (all-left-hand-key-addresses
722 . (,(make-left-hand-key-addresses '(a gis ees cis f e fis))
723 ,(make-left-hand-key-addresses '(a gis ees cis f e fis))
724 ,(make-left-hand-key-addresses '(a gis ees cis f e fis d))))
725 (low-key-group
726 . (()
727 ()
728 (,(make-right-hand-key-addresses '(low-c low-cis)))))
729 (low-rich-draw-rules
730 . (()
731 ()
732 ((,rich-group-draw-rule
733 ((left-hand . d))
734 ,(make-left-hand-key-addresses '(cis f e fis)))
735 (,rich-group-draw-rule
736 ((right-hand . low-d))
737 ((right-hand . low-cis) (right-hand . low-c))))))
738 (low-extra-offset-rule
739 . (()
740 ()
741 ((,rich-group-extra-offset-rule
742 ,(make-right-hand-key-addresses '(low-c low-d low-cis))
743 ,(make-right-hand-key-addresses '(one two three four))
744 (-0.5 . -0.7)))))
745 (bottom-right-group-key-addresses
746 . (,(make-right-hand-key-addresses '(fis e ees gis))
747 ,(make-right-hand-key-addresses '(fis e ees gis f))
748 ,(make-right-hand-key-addresses '(fis e ees gis f d))))
749 (right-hand-key-addresses
750 . (,(make-right-hand-key-addresses '(fis e ees gis))
751 ,(make-right-hand-key-addresses '(fis e ees gis f))
752 ,(make-right-hand-key-addresses
753 '(low-d low-cis low-c fis e ees gis f d)))))))
755 (define (generate-clarinet-family-entry clarinet-name)
756 (let*
757 ((change-points
758 (get-named-spreadsheet-column clarinet-name clarinet-change-points)))
759 `(,clarinet-name
760 . ((keys
761 . ((hidden
762 . ((midline
763 . ((offset . (0.0 . 0.0))
764 (stencil . ,midline-stencil)
765 (text? . #f)
766 (complexity . basic)))))
767 (central-column
768 . ((one
769 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
770 (stencil . ,column-circle-stencil)
771 (text? . #f)
772 (complexity . covered)))
773 (two
774 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
775 (stencil . ,column-circle-stencil)
776 (text? . #f)
777 (complexity . covered)))
778 (three
779 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
780 (stencil . ,column-circle-stencil)
781 (text? . #f)
782 (complexity . covered)))
783 (four
784 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
785 (stencil . ,column-circle-stencil)
786 (text? . #f)
787 (complexity . covered)))
788 (five
789 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
790 (stencil . ,column-circle-stencil)
791 (text? . #f)
792 (complexity . covered)))
793 (six
794 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
795 (stencil . ,column-circle-stencil)
796 (text? . #f)
797 (complexity . covered)))
798 (h
799 . ((offset . (0.0 . 6.25))
800 (stencil . ,(variable-column-circle-stencil 0.4))
801 (text? . #f)
802 (complexity . covered)))))
803 (left-hand
804 . ,(append `((thumb
805 . ((offset . (0.0 . 0.0))
806 (stencil . ,clarinet-lh-thumb-key-stencil)
807 (text? . #f)
808 (complexity . trill)))
809 (R
810 . ((offset . (1.0 . 1.0))
811 (stencil . ,clarinet-lh-R-key-stencil)
812 (text? . #f)
813 (complexity . trill)))
814 (a
815 . ((offset . (0.0 . 0.0))
816 (stencil . ,clarinet-lh-a-key-stencil)
817 (text? . ("A" . #f))
818 (complexity . trill)))
819 (gis
820 . ((offset . (0.8 . 1.0))
821 (stencil . ,clarinet-lh-gis-key-stencil)
822 (text? . ("G" . 1))
823 (complexity . trill)))
824 (ees
825 . ((offset . (0.0 . 0.0))
826 (stencil . ,clarinet-lh-ees-key-stencil)
827 (text? . ("E" . 0))
828 (complexity . trill)))
829 (cis
830 . ((offset . (-0.85 . 0.2))
831 (stencil . ,clarinet-lh-cis-key-stencil)
832 (text? . ("C" . 1))
833 (complexity . trill)))
834 (f
835 . ((offset . (3.6 . 0.5))
836 (stencil . ,clarinet-lh-f-key-stencil)
837 (text? . ("F" . #f))
838 (complexity . trill)))
839 (e
840 . ((offset . (2.05 . -3.65))
841 (stencil . ,clarinet-lh-e-key-stencil)
842 (text? . ("E" . #f))
843 (complexity . trill)))
844 (fis
845 . ((offset . (2.25 . -4.15))
846 (stencil . ,clarinet-lh-fis-key-stencil)
847 (text? . ("F" . 1))
848 (complexity . trill))))
849 (assoc-get 'left-extra-key-names change-points)))
850 (right-hand
851 . ,(append `((one
852 . ((offset . (0.0 . 0.75))
853 (stencil . ,clarinet-rh-one-key-stencil)
854 (text? . "1")
855 (complexity . trill)))
856 (two
857 . ((offset . (0.0 . 0.25))
858 (stencil . ,clarinet-rh-two-key-stencil)
859 (text? . "2")
860 (complexity . trill)))
861 (three
862 . ((offset . (0.0 . -0.25))
863 (stencil . ,clarinet-rh-three-key-stencil)
864 (text? . "3")
865 (complexity . trill)))
866 (four
867 . ((offset . (0.0 . -0.75))
868 (stencil . ,clarinet-rh-four-key-stencil)
869 (text? . "4")
870 (complexity . trill)))
871 (b
872 . ((offset . (0.0 . 0.0))
873 (stencil . ,clarinet-rh-b-key-stencil)
874 (text? . ("B" . #f))
875 (complexity . trill)))
876 (fis
877 . ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR))))
878 (stencil . ,clarinet-rh-fis-key-stencil)
879 (text? . ("F" . 1))
880 (complexity . trill)))
881 (e
882 . ((offset . (,(+ 1.5 CL-RH-HAIR)
883 . ,(* 3 (+ 0.75 CL-RH-HAIR))))
884 (stencil . ,clarinet-rh-e-key-stencil)
885 (text? . ("E" . #f))
886 (complexity . trill)))
887 (ees
888 . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR))))
889 (stencil . ,clarinet-rh-ees-key-stencil)
890 (text? . ("E" . 0))
891 (complexity . trill)))
892 (gis
893 . ((offset . (,(+ 1.5 CL-RH-HAIR)
894 . ,(* 1 (+ 0.75 CL-RH-HAIR))))
895 (stencil . ,clarinet-rh-gis-key-stencil)
896 (text? . ("G" . 1))
897 (complexity . trill))))
898 (assoc-get 'bottom-group-key-names change-points)))))
899 (graphical-commands
900 . ((stencil-alist
901 . ((stencils
902 . ,(append (assoc-get 'right-thumb-group change-points)
903 `(,(simple-stencil-alist '(hidden . midline)
904 '(0.0 . 3.75))
905 ((stencils
906 . ,(make-central-column-hole-addresses
907 CENTRAL-COLUMN-HOLE-H-LIST))
908 (xy-scale-function . (,identity . ,identity))
909 (textual? . #f)
910 (offset . (0.0 . 0.0)))
911 ((stencils
912 . ,(make-left-hand-key-addresses '(thumb R)))
913 (xy-scale-function . (,identity . ,identity))
914 (textual? . #f)
915 (offset . (-2.5 . 6.5)))
916 ((stencils
917 . ((left-hand . a) (left-hand . gis)))
918 (xy-scale-function . (,return-1 . ,return-1))
919 (textual? . #f)
920 (offset . (0.0 . 7.5)))
921 ,(simple-stencil-alist '(left-hand . ees)
922 '(1.0 . 5.0))
923 ((stencils
924 . ,(make-left-hand-key-addresses '(cis f e fis)))
925 (xy-scale-function . (,return-1 . ,return-1))
926 (textual? . #f)
927 (offset . (0.0 . 3.9)))
928 ((stencils
929 . ,(make-right-hand-key-addresses
930 '(one two three four)))
931 (xy-scale-function . (,return-1 . ,return-1))
932 (textual? . #f)
933 (offset . (-1.25 . 3.75)))
934 ,(simple-stencil-alist '(right-hand . b)
935 '(-1.0 . 1.5))
936 ((stencils
937 . ,(assoc-get 'bottom-right-group-key-addresses
938 change-points))
939 (xy-scale-function . (,return-1 . ,return-1))
940 (textual? . #f)
941 (offset . (-4.0 . -0.75))))))
942 (xy-scale-function . (,identity . ,identity))
943 (textual? . #f)
944 (offset . (0.0 . 0.0))))
945 (draw-instructions
946 . ,(append (assoc-get 'low-rich-draw-rules change-points)
947 `((,apply-group-draw-rule-series
948 ,(append (assoc-get 'low-key-group change-points)
949 `(((left-hand . a) (left-hand . gis))
950 ,(make-right-hand-key-addresses
951 '(one two three four))
952 ,(assoc-get 'low-left-hand-key-addresses
953 change-points)
954 ,(assoc-get 'right-hand-key-addresses
955 change-points))))
956 (,rich-group-draw-rule
957 ((left-hand . R))
958 ((left-hand . thumb)))
959 (,group-automate-rule
960 ,(make-central-column-hole-addresses
961 CENTRAL-COLUMN-HOLE-LIST))
962 (,group-automate-rule ((hidden . midline))))))
963 (extra-offset-instructions
964 . ,(append (assoc-get 'low-extra-offset-rule change-points)
965 `((,rich-group-extra-offset-rule
966 ((central-column . h))
967 ((central-column . one)
968 (left-hand . a)
969 (left-hand . gis))
970 (0.0 . 0.8))
971 (,uniform-extra-offset-rule (0.0 . 0.0)))))))
972 (text-commands
973 . ((stencil-alist
974 . ((stencils
975 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
976 ((stencils
977 . ,(make-central-column-hole-addresses
978 CENTRAL-COLUMN-HOLE-LIST))
979 (xy-scale-function . (,identity . ,identity))
980 (textual? . #f)
981 (offset . (0.0 . 0.0)))
982 ((stencils . ((left-hand . thumb) (left-hand . R)))
983 (xy-scale-function . (,identity . ,identity))
984 (textual? . #f)
985 (offset . (-2.5 . 6.5)))
986 ((stencils
987 . ,(assoc-get 'all-left-hand-key-addresses change-points))
988 (textual? . ,lh-woodwind-text-stencil)
989 (offset . (1.5 . 3.75)))
990 ((stencils
991 . ,(make-right-hand-key-addresses '(one two three four)))
992 (textual? . ,number-column-stencil)
993 (offset . (-1.25 . 3.75)))
994 ((stencils . ,(assoc-get 'right-hand-key-addresses
995 change-points))
996 (textual? . ,rh-woodwind-text-stencil)
997 (offset . (-1.25 . 0.0)))))
998 (xy-scale-function . (,identity . ,identity))
999 (textual? . #f)
1000 (offset . (0.0 . 0.0))))
1001 (draw-instructions
1002 . ((,apply-group-draw-rule-series
1003 (,(assoc-get 'all-left-hand-key-addresses change-points)
1004 ,(make-right-hand-key-addresses '(one two three four))
1005 ,(assoc-get 'right-hand-key-addresses change-points)))
1006 (,group-automate-rule
1007 ,(make-central-column-hole-addresses
1008 CENTRAL-COLUMN-HOLE-LIST))
1009 (,group-automate-rule ((hidden . midline)))))
1010 (extra-offset-instructions
1011 . ((,rich-group-extra-offset-rule
1012 ((central-column . h))
1013 ((central-column . one) (left-hand . a) (left-hand . gis))
1014 (0.0 . 0.8))
1015 (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1017 ;; Saxophone assembly instructions
1019 (define (saxophone-name-passerelle name)
1020 (cond ((eqv? name 'saxophone) 'saxophone)
1021 ((eqv? name 'soprano-saxophone) 'saxophone)
1022 ((eqv? name 'alto-saxophone) 'saxophone)
1023 ((eqv? name 'tenor-saxophone) 'saxophone)
1024 ((eqv? name 'baritone-saxophone) 'baritone-saxophone)))
1026 (define saxophone-change-points
1027 ((make-named-spreadsheet '(saxophone baritone-saxophone))
1028 `((low-a-key-definition
1029 . (()
1030 ((low-a
1031 . ((offset . (0.0 . 0.0))
1032 (stencil . ,saxophone-lh-low-a-key-stencil)
1033 (text? . #f)
1034 (complexity . trill))))))
1035 (low-a-key-group
1036 . (()
1037 (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0)))))
1038 (low-a-presence
1039 . (()
1040 ((left-hand . low-a))))
1041 (left-hand-key-names
1042 . (,(make-right-hand-key-addresses
1043 '(ees d f front-f bes gis cis b low-bes))
1044 ,(make-right-hand-key-addresses
1045 '(ees d f front-f bes gis cis b low-bes low-a)))))))
1047 (define (generate-saxophone-family-entry saxophone-name)
1048 (let*
1049 ((change-points
1050 (get-named-spreadsheet-column
1051 (saxophone-name-passerelle saxophone-name) saxophone-change-points)))
1052 `(,saxophone-name
1053 . ((keys
1054 . ((hidden
1055 . ((midline
1056 . ((offset . (0.0 . 0.0))
1057 (stencil . ,midline-stencil)
1058 (text? . #f)
1059 (complexity . basic)))))
1060 (central-column
1061 . ((one
1062 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
1063 (stencil . ,column-circle-stencil)
1064 (text? . #f)
1065 (complexity . trill)))
1066 (two
1067 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
1068 (stencil . ,column-circle-stencil)
1069 (text? . #f)
1070 (complexity . trill)))
1071 (three
1072 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
1073 (stencil . ,column-circle-stencil)
1074 (text? . #f)
1075 (complexity . trill)))
1076 (four
1077 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
1078 (stencil . ,column-circle-stencil)
1079 (text? . #f)
1080 (complexity . trill)))
1081 (five
1082 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
1083 (stencil . ,column-circle-stencil)
1084 (text? . #f)
1085 (complexity . trill)))
1086 (six
1087 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
1088 (stencil . ,column-circle-stencil)
1089 (text? . #f)
1090 (complexity . trill)))))
1091 (left-hand
1092 . ,(append (assoc-get 'low-a-key-definition change-points)
1093 `((T
1094 . ((offset . (0.0 . 0.0))
1095 (stencil . ,saxophone-lh-T-key-stencil)
1096 (text? . ("T" . #f))
1097 (complexity . trill)))
1098 (ees
1099 . ((offset . (0.4 . 1.6))
1100 (stencil . ,saxophone-lh-ees-key-stencil)
1101 (text? . ("E" . 0))
1102 (complexity . trill)))
1103 (d
1104 . ((offset . (1.5 . 0.5))
1105 (stencil . ,saxophone-lh-d-key-stencil)
1106 (text? . ("D" . #f))
1107 (complexity . trill)))
1108 (f
1109 . ((offset . (0.0 . 0.0))
1110 (stencil . ,saxophone-lh-f-key-stencil)
1111 (text? . ("F" . #f))
1112 (complexity . trill)))
1113 (front-f
1114 . ((offset . (0.0 . 0.0))
1115 (stencil . ,saxophone-lh-front-f-key-stencil)
1116 (text? . ("f" . #f))
1117 (complexity . trill)))
1118 (bes
1119 . ((offset . (0.0 . 0.0))
1120 (stencil . ,saxophone-lh-bes-key-stencil)
1121 (text? . ("B" . 0))
1122 (complexity . trill)))
1123 (gis
1124 . ((offset . (0.0 . 1.1))
1125 (stencil . ,saxophone-lh-gis-key-stencil)
1126 (text? . ("G" . 1))
1127 (complexity . trill)))
1128 (cis
1129 . ((offset . (2.4 . 0.0))
1130 (stencil . ,saxophone-lh-cis-key-stencil)
1131 (text? . ("C" . 1))
1132 (complexity . trill)))
1133 (b
1134 . ((offset . (0.0 . 0.0))
1135 (stencil . ,saxophone-lh-b-key-stencil)
1136 (text? . ("B" . #f))
1137 (complexity . trill)))
1138 (low-bes
1139 . ((offset . (0.0 . -0.2))
1140 (stencil . ,saxophone-lh-low-bes-key-stencil)
1141 (text? . ("b" . 0))
1142 (complexity . trill))))))
1143 (right-hand
1144 . ((e
1145 . ((offset . (0.0 . 2.0))
1146 (stencil . ,saxophone-rh-e-key-stencil)
1147 (text? . ("E" . #f))
1148 (complexity . trill)))
1149 (c
1150 . ((offset . (0.0 . 0.9))
1151 (stencil . ,saxophone-rh-c-key-stencil)
1152 (text? . ("C" . #f))
1153 (complexity . trill)))
1154 (bes
1155 . ((offset . (0.0 . 0.0))
1156 (stencil . ,saxophone-rh-bes-key-stencil)
1157 (text? . ("B" . 0))
1158 (complexity . trill)))
1159 (high-fis
1160 . ((offset . (0.0 . 0.0))
1161 (stencil . ,saxophone-rh-high-fis-key-stencil)
1162 (text? . ("hF" . 1))
1163 (complexity . trill)))
1164 (fis
1165 . ((offset . (0.0 . 0.0))
1166 (stencil . ,saxophone-rh-fis-key-stencil)
1167 (text? . ("F" . 1))
1168 (complexity . trill)))
1169 (ees
1170 . ((offset . (0.0 . 0.7))
1171 (stencil . ,saxophone-rh-ees-key-stencil)
1172 (text? . ("E" . 0))
1173 (complexity . trill)))
1174 (low-c
1175 . ((offset . (-1.2 . -0.1))
1176 (stencil . ,saxophone-rh-low-c-key-stencil)
1177 (text? . ("c" . #f))
1178 (complexity . trill)))))))
1179 (graphical-commands
1180 . ((stencil-alist
1181 . ((stencils
1182 . ,(append (assoc-get 'low-a-key-group change-points)
1183 `(,(simple-stencil-alist '(hidden . midline)
1184 '(0.0 . 3.75))
1185 ((stencils
1186 . ,(make-central-column-hole-addresses
1187 CENTRAL-COLUMN-HOLE-LIST))
1188 (xy-scale-function . (,identity . ,identity))
1189 (textual? . #f)
1190 (offset . (0.0 . 0.0)))
1191 ((stencils
1192 . ,(make-left-hand-key-addresses '(ees d f)))
1193 (xy-scale-function . (,return-1 . ,return-1))
1194 (textual? . #f)
1195 (offset . (1.5 . 6.8)))
1196 ,(simple-stencil-alist '(left-hand . front-f)
1197 '(0.0 . 7.35))
1198 ,(simple-stencil-alist '(left-hand . T)
1199 '(-2.2 . 6.5))
1200 ,(simple-stencil-alist '(left-hand . bes)
1201 '(0.0 . 6.2))
1202 ((stencils
1203 . ,(make-left-hand-key-addresses
1204 '(gis cis b low-bes)))
1205 (xy-scale-function . (,return-1 . ,return-1))
1206 (textual? . #f)
1207 (offset . (1.2 . 3.5)))
1208 ((stencils
1209 . ,(make-right-hand-key-addresses '(e c bes)))
1210 (xy-scale-function . (,return-1 . ,return-1))
1211 (textual? . #f)
1212 (offset . (-2.3 . 3.4)))
1213 ,(simple-stencil-alist '(right-hand . high-fis)
1214 '(-1.8 . 2.5))
1215 ,(simple-stencil-alist '(right-hand . fis)
1216 '(-1.5 . 1.5))
1217 ((stencils
1218 . ,(make-right-hand-key-addresses '(ees low-c)))
1219 (xy-scale-function . (,return-1 . ,return-1))
1220 (textual? . #f)
1221 (offset . (-2.0 . 0.3))))))
1222 (xy-scale-function . (,identity . ,identity))
1223 (textual? . #f)
1224 (offset . (0.0 . 0.0))))
1225 (draw-instructions
1226 . ((,apply-group-draw-rule-series
1227 (,(make-left-hand-key-addresses '(ees d f))
1228 ,(make-left-hand-key-addresses '(gis cis b low-bes))
1229 ,(make-right-hand-key-addresses '(e c bes))
1230 ,(make-right-hand-key-addresses '(ees low-c))))
1231 (,group-automate-rule
1232 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
1233 (,group-automate-rule ((hidden . midline)))))
1234 (extra-offset-instructions
1235 . ((,rich-group-extra-offset-rule
1236 ((left-hand . bes))
1237 ,(append (assoc-get 'low-a-presence change-points)
1238 '((central-column . one)
1239 (left-hand . front-f)
1240 (left-hand . T)
1241 (left-hand . ees)
1242 (left-hand . d)
1243 (left-hand . f)))
1244 (0.0 . 1.0))
1245 (,uniform-extra-offset-rule (0.0 . 0.0))))))
1246 (text-commands
1247 . ((stencil-alist
1248 . ((stencils
1249 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
1250 ((stencils
1251 . ,(make-central-column-hole-addresses
1252 CENTRAL-COLUMN-HOLE-LIST))
1253 (xy-scale-function . (,identity . ,identity))
1254 (textual? . #f)
1255 (offset . (0.0 . 0.0)))
1256 ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0))
1257 ((stencils
1258 . ,(assoc-get 'left-hand-key-names change-points))
1259 (textual? . ,lh-woodwind-text-stencil)
1260 (offset . (1.5 . 3.75)))
1261 ((stencils
1262 . ,(make-right-hand-key-addresses
1263 '(e c bes high-fis fis ees low-c)))
1264 (textual? . ,rh-woodwind-text-stencil)
1265 (offset . (-1.25 . 0.0)))))
1266 (xy-scale-function . (,identity . ,identity))
1267 (textual? . #f)
1268 (offset . (0.0 . 0.0))))
1269 (draw-instructions
1270 . ((,apply-group-draw-rule-series
1271 (,(make-left-hand-key-addresses
1272 '(ees d f front-f bes gis cis b low-bes))
1273 ,(make-right-hand-key-addresses
1274 '(e c bes high-fis fis ees low-c))))
1275 (,group-automate-rule
1276 ,(make-central-column-hole-addresses
1277 CENTRAL-COLUMN-HOLE-LIST))
1278 (,group-automate-rule ((hidden . midline)))))
1279 (extra-offset-instructions
1280 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1282 ;; Bassoon assembly instructions
1284 (define bassoon-change-points
1285 ((make-named-spreadsheet '(bassoon contrabassoon))
1286 `((left-hand-additional-keys .
1287 (((a .
1288 ((offset . (0.0 . -0.3))
1289 (stencil . ,bassoon-lh-a-flick-key-stencil)
1290 (text? . ("A" . #f))
1291 (complexity . trill)))
1292 (w .
1293 ((offset . (0.0 . 0.0))
1294 (stencil . ,bassoon-lh-whisper-key-stencil)
1295 (text? . ("w" . #f))
1296 (complexity . trill))))
1297 ()))
1298 (right-hand-additional-keys .
1299 (((cis .
1300 ((offset . (0.0 . 0.0))
1301 (stencil . ,bassoon-rh-cis-key-stencil)
1302 (text? . ("C" . 1))
1303 (complexity . trill)))
1304 (thumb-gis .
1305 ((offset . (0.0 . 0.0))
1306 (stencil . ,bassoon-rh-thumb-gis-key-stencil)
1307 (text? . ("G" . 1))
1308 (complexity . trill))))
1309 ()))
1310 (left-hand-flick-group .
1311 (((left-hand . d) (left-hand . c) (left-hand . a))
1312 ((left-hand . d) (left-hand . c))))
1313 (left-hand-thumb-group .
1314 (((left-hand . w) (left-hand . thumb-cis))
1315 ((left-hand . thumb-cis))))
1316 (cis-offset-instruction .
1317 (((,rich-group-extra-offset-rule
1318 ((right-hand . cis))
1319 ,(append
1320 '((hidden . midline) (hidden . long-midline))
1321 (make-central-column-hole-addresses '(three two one))
1322 (make-left-hand-key-addresses
1323 '(low-b low-bes low-c low-d d a c w thumb-cis
1324 high-ees high-e cis ees)))
1325 (0.0 . 0.9)))
1326 ()))
1327 (right-hand-lower-thumb-group .
1328 (((right-hand . thumb-gis) (right-hand . thumb-fis))
1329 ((right-hand . thumb-fis))))
1330 (right-hand-cis-key .
1331 ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22)))
1332 ()))
1333 (back-left-hand-key-addresses .
1334 ((low-b low-bes low-c low-d d a c w thumb-cis)
1335 (low-b low-bes low-c low-d d c thumb-cis)))
1336 (front-right-hand-key-addresses .
1337 ((cis bes fis f gis) (bes fis f gis)))
1338 (back-right-hand-key-addresses .
1339 ((thumb-bes thumb-gis thumb-e thumb-fis)
1340 (thumb-bes thumb-e thumb-fis))))))
1342 (define (generate-bassoon-family-entry bassoon-name)
1343 (let*
1344 ((change-points
1345 (get-named-spreadsheet-column bassoon-name bassoon-change-points)))
1346 `(,bassoon-name
1347 . ((keys
1348 . ((hidden
1349 . ((midline
1350 . ((offset . (0.0 . 0.0))
1351 (stencil . ,midline-stencil)
1352 (text? . #f)
1353 (complexity . basic)))
1354 (long-midline
1355 . ((offset . (0.0 . 0.0))
1356 (stencil . ,long-midline-stencil)
1357 (text? . #f)
1358 (complexity . basic)))))
1359 (central-column
1360 . ((one
1361 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
1362 (stencil . ,bassoon-cc-one-key-stencil)
1363 (text? . #f)
1364 (complexity . trill)))
1365 (two
1366 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
1367 (stencil . ,ring-column-circle-stencil)
1368 (text? . #f)
1369 (complexity . ring)))
1370 (three
1371 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
1372 (stencil . ,ring-column-circle-stencil)
1373 (text? . #f)
1374 (complexity . ring)))
1375 (four
1376 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
1377 (stencil . ,ring-column-circle-stencil)
1378 (text? . #f)
1379 (complexity . ring)))
1380 (five
1381 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
1382 (stencil . ,ring-column-circle-stencil)
1383 (text? . #f)
1384 (complexity . ring)))
1385 (six
1386 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
1387 (stencil . ,ring-column-circle-stencil)
1388 (text? . #f)
1389 (complexity . ring)))))
1390 (left-hand
1391 . ,(append (assoc-get 'left-hand-additional-keys
1392 change-points)
1393 `((high-e
1394 . ((offset . (0.0 . 0.0))
1395 (stencil . ,bassoon-lh-he-key-stencil)
1396 (text? . ("hE" . #f))
1397 (complexity . trill)))
1398 (high-ees
1399 . ((offset . (0.0 . 0.0))
1400 (stencil . ,bassoon-lh-hees-key-stencil)
1401 (text? . ("hE" . 0))
1402 (complexity . trill)))
1403 (ees
1404 . ((offset . (-1.0 . 1.0))
1405 (stencil . ,bassoon-lh-ees-key-stencil)
1406 (text? . ("E" . 0))
1407 (complexity . trill)))
1408 (cis
1409 . ((offset . (0.0 . 0.0))
1410 (stencil . ,bassoon-lh-cis-key-stencil)
1411 (text? . ("C" . 1))
1412 (complexity . trill)))
1413 (low-bes
1414 . ((offset . (0.0 . 0.0))
1415 (stencil . ,bassoon-lh-lbes-key-stencil)
1416 (text? . ("b" . 0))
1417 (complexity . trill)))
1418 (low-b
1419 . ((offset . (-1.0 . -0.7))
1420 (stencil . ,bassoon-lh-lb-key-stencil)
1421 (text? . ("b" . #f))
1422 (complexity . trill)))
1423 (low-c
1424 . ((offset . (0.0 . 0.0))
1425 (stencil . ,bassoon-lh-lc-key-stencil)
1426 (text? . ("c" . #f))
1427 (complexity . trill)))
1428 (low-d
1429 . ((offset . (0.0 . 0.0))
1430 (stencil . ,bassoon-lh-ld-key-stencil)
1431 (text? . ("d" . #f))
1432 (complexity . trill)))
1433 (d
1434 . ((offset . (-1.5 . 2.0))
1435 (stencil . ,bassoon-lh-d-flick-key-stencil)
1436 (text? . ("D" . #f))
1437 (complexity . trill)))
1438 (c
1439 . ((offset . (-0.8 . 1.1))
1440 (stencil . ,bassoon-lh-c-flick-key-stencil)
1441 (text? . ("C" . #f))
1442 (complexity . trill)))
1443 (thumb-cis
1444 . ((offset . (2.0 . -1.0))
1445 (stencil . ,bassoon-lh-thumb-cis-key-stencil)
1446 (text? . ("C" . 1))
1447 (complexity . trill))))))
1448 (right-hand
1449 . ,(append (assoc-get 'right-hand-additional-keys
1450 change-points)
1451 `((bes
1452 . ((offset . (0.0 . 0.8))
1453 (stencil . ,bassoon-rh-bes-key-stencil)
1454 (text? . ("B" . 0))
1455 (complexity . trill)))
1456 (f
1457 . ((offset . (-2.2 . 4.35))
1458 (stencil . ,bassoon-rh-f-key-stencil)
1459 (text? . ("F" . #f))
1460 (complexity . trill)))
1461 (fis
1462 . ((offset . (1.5 . 1.0))
1463 (stencil . ,bassoon-rh-fis-key-stencil)
1464 (text? . ("F" . 1))
1465 (complexity . trill)))
1466 (gis
1467 . ((offset . (0.0 . -0.15))
1468 (stencil . ,bassoon-rh-gis-key-stencil)
1469 (text? . ("G" . 1))
1470 (complexity . trill)))
1471 (thumb-bes
1472 . ((offset . (0.0 . 0.0))
1473 (stencil . ,bassoon-rh-thumb-bes-key-stencil)
1474 (text? . ("B" . 0))
1475 (complexity . trill)))
1476 (thumb-e
1477 . ((offset . (1.75 . 0.4))
1478 (stencil . ,bassoon-rh-thumb-e-key-stencil)
1479 (text? . ("E" . #f))
1480 (complexity . trill)))
1481 (thumb-fis
1482 . ((offset . (-1.0 . 1.6))
1483 (stencil . ,bassoon-rh-thumb-fis-key-stencil)
1484 (text? . ("F" . 1))
1485 (complexity . trill))))))))
1486 (graphical-commands
1487 . ((stencil-alist
1488 . ((stencils
1489 . ,(append (assoc-get 'right-hand-cis-key change-points)
1490 `(,(simple-stencil-alist '(hidden . midline)
1491 '(0.0 . 3.75))
1492 ,(simple-stencil-alist '(hidden . long-midline)
1493 '(0.0 . 3.80))
1494 ((stencils
1495 . ,(make-central-column-hole-addresses
1496 CENTRAL-COLUMN-HOLE-LIST))
1497 (xy-scale-function . (,identity . ,identity))
1498 (textual? . #f)
1499 (offset . (0.0 . 0.0)))
1500 ,(simple-stencil-alist '(left-hand . high-e)
1501 '(-1.0 . 7.0))
1502 ,(simple-stencil-alist '(left-hand . high-ees)
1503 '(-1.0 . 6.0))
1504 ((stencils
1505 . ((left-hand . ees) (left-hand . cis)))
1506 (xy-scale-function . (,return-1 . ,return-1))
1507 (textual? . #f)
1508 (offset . (3.0 . 3.75)))
1509 ((stencils
1510 . (((stencils
1511 . ((left-hand . low-b)
1512 (left-hand . low-bes)))
1513 (xy-scale-function
1514 . (,return-1 . ,return-1))
1515 (textual? . #f)
1516 (offset . (-2.0 . 9.0)))
1517 ((stencils
1518 . ,(assoc-get 'left-hand-flick-group
1519 change-points))
1520 (xy-scale-function
1521 . (,return-1 . ,return-1))
1522 (textual? . #f)
1523 (offset . (3.0 . 7.0)))
1524 ,(simple-stencil-alist '(left-hand . low-c)
1525 '(-1.0 . 4.5))
1526 ,(simple-stencil-alist '(left-hand . low-d)
1527 '(-1.0 . 0.1))
1528 ((stencils
1529 . ,(assoc-get 'left-hand-thumb-group
1530 change-points))
1531 (xy-scale-function
1532 . (,return-1 . ,return-1))
1533 (textual? . #f)
1534 (offset . (1.5 . -0.6)))))
1535 (xy-scale-function . (,return-1 . ,return-1))
1536 (textual? . #f)
1537 (offset . (-5.5 . 4.7)))
1538 ,(simple-stencil-alist '(right-hand . bes)
1539 '(1.0 . 1.2))
1540 ((stencils
1541 . ,(make-right-hand-key-addresses '(gis f fis)))
1542 (xy-scale-function . (,return-1 . ,return-1))
1543 (textual? . #f)
1544 (offset . (2.0 . -1.25)))
1545 ((stencils
1546 . (((stencils
1547 . ((right-hand . thumb-bes)
1548 (right-hand . thumb-e)))
1549 (xy-scale-function
1550 . (,return-1 . ,return-1))
1551 (textual? . #f)
1552 (offset . (-1.22 . 5.25)))
1553 ((stencils
1554 . ,(assoc-get 'right-hand-lower-thumb-group
1555 change-points))
1556 (xy-scale-function
1557 . (,return-1 . ,return-1))
1558 (textual? . #f)
1559 (offset . (0.0 . 0.0)))))
1560 (xy-scale-function
1561 . (,return-1 . ,return-1))
1562 (textual? . #f)
1563 (offset . (-5.0 . 0.0))))))
1564 (xy-scale-function . (,identity . ,identity))
1565 (textual? . #f)
1566 (offset . (0.0 . 0.0))))
1567 (draw-instructions
1568 . ((,apply-group-draw-rule-series
1569 (,(make-left-hand-key-addresses '(ees cis))
1570 ,(make-left-hand-key-addresses
1571 (assoc-get 'back-left-hand-key-addresses change-points))
1572 ,(make-right-hand-key-addresses '(f fis gis))
1573 ,(make-right-hand-key-addresses
1574 (assoc-get 'back-right-hand-key-addresses change-points))))
1575 (,group-automate-rule
1576 ,(make-central-column-hole-addresses
1577 CENTRAL-COLUMN-HOLE-LIST))
1578 (,bassoon-midline-rule
1579 ,(append
1580 (make-left-hand-key-addresses
1581 (assoc-get 'back-left-hand-key-addresses change-points))
1582 (make-right-hand-key-addresses
1583 (assoc-get 'back-right-hand-key-addresses
1584 change-points))))))
1585 (extra-offset-instructions
1586 . ,(append
1587 (assoc-get 'cis-offset-instruction change-points)
1588 `((,uniform-extra-offset-rule (0.0 . 0.0)))))))
1589 (text-commands
1590 . ((stencil-alist
1591 . ((stencils
1592 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
1593 ((stencils
1594 . ,(make-central-column-hole-addresses
1595 CENTRAL-COLUMN-HOLE-LIST))
1596 (xy-scale-function . (,identity . ,identity))
1597 (textual? . #f)
1598 (offset . (0.0 . 0.0)))
1599 ((stencils
1600 . ,(make-left-hand-key-addresses
1601 '(high-e high-ees ees cis)))
1602 (textual? . ,lh-woodwind-text-stencil)
1603 (offset . (1.5 . 3.75)))
1604 ((stencils
1605 . ,(make-left-hand-key-addresses
1606 (assoc-get 'back-left-hand-key-addresses
1607 change-points)))
1608 (textual? . ,rh-woodwind-text-stencil)
1609 (offset . (-1.25 . 3.75)))
1610 ((stencils
1611 . ,(make-right-hand-key-addresses
1612 (assoc-get 'front-right-hand-key-addresses
1613 change-points)))
1614 (textual? . ,lh-woodwind-text-stencil)
1615 (offset . (1.5 . 0.0)))
1616 ((stencils .
1617 ,(make-right-hand-key-addresses
1618 (assoc-get 'back-right-hand-key-addresses
1619 change-points)))
1620 (textual? . ,rh-woodwind-text-stencil)
1621 (offset . (-1.25 . 0.0)))))
1622 (xy-scale-function . (,identity . ,identity))
1623 (textual? . #f)
1624 (offset . (0.0 . 0.0))))
1625 (draw-instructions
1626 . ((,apply-group-draw-rule-series
1627 (,(make-left-hand-key-addresses
1628 (assoc-get 'back-left-hand-key-addresses change-points))
1629 ,(make-right-hand-key-addresses
1630 (assoc-get 'front-right-hand-key-addresses change-points))
1631 ,(make-right-hand-key-addresses
1632 (assoc-get 'back-right-hand-key-addresses change-points))
1633 ,(make-left-hand-key-addresses '(high-e high-ees ees cis))))
1634 (,group-automate-rule
1635 ,(make-central-column-hole-addresses
1636 CENTRAL-COLUMN-HOLE-LIST))
1637 (,group-automate-rule ((hidden . midline)))))
1638 (extra-offset-instructions
1639 . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1641 ;; Assembly functions
1643 ; Scans a bank for name.
1644 ; for example, '(left-hand . bes) will return bes in the left-hand
1645 ; of a given bank
1646 (define (get-key name bank)
1647 (assoc-get (cdr name) (assoc-get (car name) bank)))
1649 (define (translate-key-instruction key-instruction)
1650 (let*
1651 ((key-name (car key-instruction))
1652 (key-complexity (assoc-get 'complexity (cdr key-instruction))))
1653 (cond
1654 ((eqv? key-complexity 'basic)
1655 `((,key-name . ,(assoc-get 'F HOLE-FILL-LIST))))
1656 ((eqv? key-complexity 'trill)
1657 (make-symbol-alist key-name #t #f))
1658 ((eqv? key-complexity 'covered)
1659 (make-symbol-alist key-name #f #f))
1660 ((eqv? key-complexity 'ring)
1661 (make-symbol-alist key-name #f #t)))))
1663 (define (update-possb-list input-key possibility-list canonic-list)
1664 (if (null? possibility-list)
1665 (ly:error "woodwind markup error - invalid key or hole requested")
1666 (if
1667 (assoc-get input-key (cdar possibility-list))
1668 (append
1669 `(((,(caaar possibility-list) .
1670 ,(assoc-get input-key (cdar possibility-list))) .
1671 ,(assoc-get (caar possibility-list) canonic-list)))
1672 (assoc-remove (caar possibility-list) canonic-list))
1673 (update-possb-list input-key (cdr possibility-list) canonic-list))))
1675 (define (key-crawler input-list possibility-list)
1676 (if (null? input-list)
1677 (map car possibility-list)
1678 (key-crawler
1679 (cdr input-list)
1680 (update-possb-list
1681 (car input-list)
1682 possibility-list
1683 possibility-list))))
1685 (define (translate-draw-instructions input-alist key-name-alist)
1686 (apply append
1687 (map (lambda (short long)
1688 (let*
1689 ((key-instructions
1690 (map (lambda (instr)
1691 `(((,long . ,(car instr)) . 0)
1692 . ,(translate-key-instruction instr)))
1693 (assoc-get long key-name-alist))))
1694 (key-crawler (assoc-get short input-alist) key-instructions)))
1695 '(hd cc lh rh)
1696 '(hidden central-column left-hand right-hand))))
1698 (define (uniform-draw-instructions key-name-alist)
1699 (apply append
1700 (map (lambda (long)
1701 (map (lambda (key-instructions)
1702 `((,long . ,(car key-instructions)) . 1))
1703 (assoc-get long key-name-alist)))
1704 '(hidden central-column left-hand right-hand))))
1706 (define (list-all-possible-keys key-name-alist)
1707 (map (lambda (short long)
1708 `(,short
1709 . ,(map (lambda (key-instructions)
1710 (car key-instructions))
1711 (assoc-get long key-name-alist))))
1712 '(cc lh rh)
1713 '(central-column left-hand right-hand)))
1715 (define (list-all-possible-keys-verbose key-name-alist)
1716 (map (lambda (short long)
1717 `(,short
1718 . ,(map (lambda (key-instructions)
1719 `(,(car key-instructions)
1720 . ,(map (lambda (x)
1721 (car x))
1722 (translate-key-instruction key-instructions))))
1723 (assoc-get long key-name-alist))))
1724 '(cc lh rh)
1725 '(central-column left-hand right-hand)))
1727 (define woodwind-data-assembly-instructions
1728 `((,generate-flute-family-entry . piccolo)
1729 (,generate-flute-family-entry . flute)
1730 (,generate-flute-family-entry . flute-b-extension)
1731 (,generate-tin-whistle-family-entry . tin-whistle)
1732 (,generate-oboe-family-entry . oboe)
1733 (,generate-clarinet-family-entry . clarinet)
1734 (,generate-clarinet-family-entry . bass-clarinet)
1735 (,generate-clarinet-family-entry . low-bass-clarinet)
1736 (,generate-saxophone-family-entry . saxophone)
1737 (,generate-saxophone-family-entry . soprano-saxophone)
1738 (,generate-saxophone-family-entry . alto-saxophone)
1739 (,generate-saxophone-family-entry . tenor-saxophone)
1740 (,generate-saxophone-family-entry . baritone-saxophone)
1741 (,generate-bassoon-family-entry . bassoon)
1742 (,generate-bassoon-family-entry . contrabassoon)))
1744 (define-public woodwind-instrument-list
1745 (map cdr woodwind-data-assembly-instructions))
1747 (define woodwind-data-alist
1748 (map (lambda (instruction)
1749 ((car instruction) (cdr instruction)))
1750 woodwind-data-assembly-instructions))
1752 ;;; The brains of the markup function: takes drawing and offset information
1753 ;;; about a key region and calls the appropriate stencils to draw the region.
1755 (define
1756 (assemble-stencils
1757 stencil-alist
1758 key-bank
1759 draw-instructions
1760 extra-offset-instructions
1761 radius
1762 thick
1763 xy-stretch
1764 layout
1765 props)
1766 (apply
1767 ly:stencil-add
1768 (map (lambda (node)
1769 (ly:stencil-translate
1770 (if (pair? (cdr node))
1771 (if (assoc-get 'textual? node)
1772 ((assoc-get 'textual? node) (map (lambda (key)
1773 (assoc-get 'text? key))
1774 (map (lambda (instr)
1775 (get-key
1776 instr
1777 key-bank))
1778 (assoc-get 'stencils node)))
1779 radius
1780 (map (lambda (key)
1781 (assoc-get
1782 key
1783 draw-instructions))
1784 (assoc-get 'stencils
1785 node))
1786 layout
1787 props)
1788 (assemble-stencils
1789 node
1790 key-bank
1791 draw-instructions
1792 extra-offset-instructions
1793 radius
1794 thick
1795 (coord-apply (assoc-get 'xy-scale-function stencil-alist)
1796 xy-stretch)
1797 layout
1798 props))
1799 (if (= 0 (assoc-get node draw-instructions))
1800 empty-stencil
1801 ((assoc-get 'stencil (get-key node key-bank))
1802 radius
1803 thick
1804 (assoc-get node draw-instructions)
1805 layout
1806 props)))
1807 (coord-scale
1808 (coord-translate
1809 (coord-scale
1810 (assoc-get
1811 'offset
1812 (if (pair? (cdr node))
1813 node
1814 (get-key node key-bank)))
1815 (coord-apply
1816 (assoc-get 'xy-scale-function stencil-alist)
1817 xy-stretch))
1818 (if
1819 (assoc-get node extra-offset-instructions)
1820 (assoc-get node extra-offset-instructions)
1821 '(0.0 . 0.0)))
1822 radius)))
1823 (assoc-get 'stencils stencil-alist))))
1825 (define-public (print-keys instrument)
1826 (let*
1827 ((chosen-instrument
1828 (begin
1829 (format #t "\nPrinting keys for: ~a\n" instrument)
1830 (assoc-get instrument woodwind-data-alist)))
1831 (key-list (list-all-possible-keys (assoc-get 'keys chosen-instrument))))
1832 (define (key-list-loop key-list)
1833 (if (null? key-list)
1834 0
1835 (begin
1836 (format #t "~a\n ~a\n" (caar key-list) (cdar key-list))
1837 (key-list-loop (cdr key-list)))))
1838 (key-list-loop key-list)))
1840 (define-public (get-woodwind-key-list instrument)
1841 (list-all-possible-keys-verbose
1842 (assoc-get
1843 'keys
1844 (assoc-get instrument woodwind-data-alist))))
1846 (define-public (print-keys-verbose instrument)
1847 (let*
1848 ((chosen-instrument
1849 (begin
1850 (format #t "\nPrinting keys in verbose mode for: ~a\n" instrument)
1851 (assoc-get instrument woodwind-data-alist)))
1852 (key-list
1853 (list-all-possible-keys-verbose (assoc-get 'keys chosen-instrument))))
1854 (define (key-list-loop key-list)
1855 (if (null? key-list)
1856 0
1857 (begin
1858 (format #t "~a\n" (caar key-list))
1859 (map (lambda (x)
1860 (format #t " possibilities for ~a:\n ~a\n" (car x) (cdr x)))
1861 (cdar key-list))
1862 (key-list-loop (cdr key-list)))))
1863 (key-list-loop key-list)))
1865 (define-markup-command
1866 (woodwind-diagram layout props instrument user-draw-commands)
1867 (symbol? list?)
1868 #:category instrument-specific-markup ; markup category
1869 #:properties ((size 1)
1870 (thickness 0.1)
1871 (graphical #t))
1872 "Make a woodwind-instrument diagram. For example, say
1874 @example
1875 \\markup \\woodwind-diagram #'oboe #'((lh . (d ees)) (cc . (five3qT1q)) (rh . (gis)))
1876 @end example
1878 @noindent
1879 for an oboe with the left-hand d key, left-hand ees key,
1880 and right-hand gis key depressed while the five-hole of
1881 the central column effectuates a trill between 1/4 and 3/4 closed.
1883 The following instruments are supported:
1884 @itemize @minus
1886 @item
1887 piccolo
1889 @item
1890 flute
1892 @item
1893 oboe
1895 @item
1896 clarinet
1898 @item
1899 bass-clarinet
1901 @item
1902 saxophone
1904 @item
1905 bassoon
1907 @item
1908 contrabassoon
1910 @end itemize
1912 To see all of the callable keys for a given instrument,
1913 include the function @code{(print-keys 'instrument)}
1914 in your .ly file, where instrument is the instrument
1915 whose keys you want to print.
1917 Certain keys allow for special configurations. The entire gamut of
1918 configurations possible is as follows:
1920 @itemize @minus
1922 @item
1923 1q (1/4 covered)
1925 @item
1926 1h (1/2 covered)
1928 @item
1929 3q (3/4 covered)
1931 @item
1932 R (ring depressed)
1934 @item
1935 F (fully covered; the default if no state put)
1937 @end itemize
1939 Additionally, these configurations can be used in trills. So, for example,
1940 @code{three3qTR} effectuates a trill between 3/4 full and ring depressed
1941 on the three hole. As another example, @code{threeRT} effectuates a trill
1942 between R and open, whereas @code{threeTR} effectuates a trill between open
1943 and shut. To see all of the possibilities for all of the keys of a given
1944 instrument, invoke @code{(print-keys-verbose 'instrument)}.
1946 Lastly, substituting an empty list for the pressed-key alist will result in
1947 a diagram with all of the keys drawn but none filled. ie...
1949 @example
1950 \\markup \\woodwind-diagram #'oboe #'()
1951 @end example"
1952 (let* ((radius size)
1953 (thick (* size thickness))
1954 (display-graphic graphical)
1955 (xy-stretch `(1.0 . 2.5))
1956 (chosen-instrument (assoc-get instrument woodwind-data-alist))
1957 (chosen-instrument
1958 (if (not chosen-instrument)
1959 (ly:error "~a is not a valid woodwind instrument."
1960 instrument)
1961 chosen-instrument))
1962 (stencil-info
1963 (assoc-get
1964 (if display-graphic 'graphical-commands 'text-commands)
1965 chosen-instrument))
1966 (pressed-info
1967 (if (null? user-draw-commands)
1968 (uniform-draw-instructions (assoc-get 'keys chosen-instrument))
1969 (translate-draw-instructions
1970 (append '((hd . ())) user-draw-commands)
1971 (assoc-get 'keys chosen-instrument))))
1972 (draw-info
1973 (function-chain
1974 pressed-info
1975 (assoc-get 'draw-instructions stencil-info)))
1976 (extra-offset-info
1977 (function-chain
1978 pressed-info
1979 (assoc-get 'extra-offset-instructions stencil-info))))
1980 (assemble-stencils
1981 (assoc-get 'stencil-alist stencil-info)
1982 (assoc-get 'keys chosen-instrument)
1983 draw-info
1984 extra-offset-info
1985 radius
1986 thick
1987 xy-stretch
1988 layout
1989 props)))