Left: | ||
Right: |
OLD | NEW |
---|---|
(Empty) | |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | |
2 ;;;; | |
3 ;;;; Copyright (C) 2010 Mike Solomon <mikesol@stanfordalumni.org> | |
4 ;;;; Clarinet drawings copied from diagrams created by | |
5 ;;;; Gilles Thibault <gilles.thibault@free.fr> | |
6 ;;;; | |
7 ;;;; LilyPond is free software: you can redistribute it and/or modify | |
8 ;;;; it under the terms of the GNU General Public License as published by | |
9 ;;;; the Free Software Foundation, either version 3 of the License, or | |
10 ;;;; (at your option) any later version. | |
11 ;;;; | |
12 ;;;; LilyPond is distributed in the hope that it will be useful, | |
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 ;;;; GNU General Public License for more details. | |
16 ;;;; | |
17 ;;;; You should have received a copy of the GNU General Public License | |
18 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. | |
19 | |
20 (define HOLE-FILL-LIST '((R . 3) (1q . 5) (1h . 7) (3q . 11) (F . 13))) | |
21 | |
22 ;; Utility functions | |
23 | |
24 (define-public (symbol-concatenate . names) | |
25 "Like string-concatenate, but for symbols" | |
26 (string->symbol (apply string-append (map symbol->string names)))) | |
27 | |
28 (define-public (function-chain arg function-list) | |
29 "Applies a list of functions in function list to arg. | |
30 Each element of function list is structured (cons function '(arg2 arg3 ...)) | |
31 If function takes arguments besides arg, they are provided in function list. | |
32 For example: | |
33 @code{guile> (function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))} | |
34 @code{1/3}" | |
35 (if (null? function-list) | |
36 arg | |
37 (function-chain | |
38 (apply (caar function-list) (append `(,arg) (cdar function-list))) | |
39 (cdr function-list)))) | |
40 | |
41 (define (rotunda-map function inlist rotunda) | |
42 "Like map, but with a rotating last argument to function. | |
43 For example: | |
44 @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))} | |
45 @code{(2 -8 4 -6)}" | |
46 (define (rotunda-map-chain function inlist outlist rotunda) | |
47 (if (null? inlist) | |
48 outlist | |
49 (rotunda-map-chain | |
50 function | |
51 (cdr inlist) | |
52 (append outlist (list (function (car inlist) (car rotunda)))) | |
53 (append (cdr rotunda) (list (car rotunda)))))) | |
54 (rotunda-map-chain function inlist '() rotunda)) | |
55 | |
56 (define (assoc-remove key alist) | |
57 "Remove key (and its corresponding value) from an alist. | |
58 Different than assoc-remove! because it is non-destructive." | |
59 (define (assoc-crawler key l r) | |
60 (if (null? r) | |
61 l | |
62 (if (equal? (caar r) key) | |
63 (append l (cdr r)) | |
64 (assoc-crawler key (append l `(,(car r))) (cdr r))))) | |
65 (assoc-crawler key '() alist)) | |
66 | |
67 (define (assoc-keys alist) | |
68 "Gets the keys of an alist." | |
69 (map (lambda (x) (car x)) alist)) | |
70 | |
71 (define (assoc-values alist) | |
72 "Gets the values of an alist." | |
73 (map (lambda (x) (cdr x)) alist)) | |
74 | |
75 (define (get-slope-offset p1 p2) | |
76 "Gets the slope and offset for p1 and p2. | |
77 For example: | |
78 @code{(get-slope-offset '(1 . 2) '(3 . -5.1))} | |
79 @code{(-3.55 . 5.55)}" | |
80 (let* | |
81 ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2)))) | |
82 (offset (- (cdr p1) (* slope (car p1))))) | |
83 `(,slope . ,offset))) | |
84 | |
85 (define (is-square? x input-list) | |
86 "Returns true if x is the square of a value in input-list." | |
87 (let ((y (inexact->exact (sqrt x)))) | |
88 (if (member y input-list) #t #f))) | |
Neil Puttock
2010/05/31 14:48:13
(pair? (memv y input-list))
| |
89 | |
90 (define (satisfies-function? function input-list) | |
91 "Returns true if an element in @code{input-list} is true | |
92 when @code{function} is applied to it. | |
93 For example: | |
94 @code{guile> (satisfies-function? null? '((1 2) ()))} | |
95 @code{#t} | |
96 @code{guile> (satisfies-function? null? '((1 2) (3)))} | |
97 @code{#f}" | |
98 (if (null? input-list) | |
99 #f | |
100 (or (function (car input-list)) | |
101 (satisfies-function? function (cdr input-list))))) | |
102 | |
103 (define (true-entry? input-list) | |
104 "Is there a true entry in @code{input-list}?" | |
105 (satisfies-function? return-x input-list)) | |
106 | |
107 (define (entry-greater-than-x? input-list x) | |
108 "Is there an entry greater than @code{x} in @code{input-list}?" | |
109 (satisfies-function? (lambda (y) (> y x)) input-list)) | |
110 | |
111 (define (n-true-entries input-list) | |
112 "Returns number of true entries in @code{input-list}." | |
113 (reduce + 0 (map (lambda (x) (if x 1 0)) input-list))) | |
114 | |
115 (define (return-1 x) 1.0) | |
116 | |
117 (define (return-x x) x) | |
Neil Puttock
2010/05/31 14:48:13
= identity
| |
118 | |
119 (define (make-spreadsheet parameter-list) | |
120 "Makes a spreadsheet function with columns of parameter-list. | |
121 This function can then be filled with rows. | |
122 For example: | |
123 @code{guile> ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6)))} | |
124 @code{(((foo . 1) (bar . 2)) ((foo . 3) (bar . 4)) ((foo . 5) (bar . 6)))}" | |
125 (lambda (ls) | |
126 (map | |
127 (lambda | |
128 (list-to-translate) | |
129 (map | |
130 (lambda (name element) `(,name . ,element)) | |
131 parameter-list | |
132 list-to-translate)) | |
133 ls))) | |
134 | |
135 (define (get-spreadsheet-column column spreadsheet) | |
136 "Gets all the values in @code{column} form @code{spreadsheet} | |
137 made by @{make-spreadsheet}. | |
138 For example: | |
139 @code{guile> (get-spreadsheet-column 'bar ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6))))} | |
140 @code{(2 4 6)}" | |
141 (map (lambda (row) (assoc-get column row)) spreadsheet)) | |
142 | |
143 (define (make-named-spreadsheet parameter-list) | |
144 "Makes a named spreadsheet function with columns of parameter-list. | |
145 This function can then be filled with named rows | |
146 For example: | |
147 @code{guile> ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) ( z . (5 6))))} | |
148 @code{((x (foo . 1) (bar . 2)) (y (foo . 3) (bar . 4)) (z (foo . 5) (bar . 6) ))}" | |
149 (lambda (ls) | |
150 (map | |
151 (lambda | |
152 (list-to-translate) | |
153 `(,(list-ref list-to-translate 0) . | |
154 ,(map | |
155 (lambda (name element) `(,name . ,element)) | |
156 parameter-list | |
157 (list-tail list-to-translate 1)))) | |
158 ls))) | |
159 | |
160 (define (get-named-spreadsheet-column column spreadsheet) | |
161 "Gets all the values in @code{column} form @code{spreadsheet} | |
162 made by @{make-named-spreadsheet}. | |
163 For example: | |
164 @code{guile> (get-spreadsheet-column 'bar ((make-named-spreadsheet '(foo bar) ) '((x . (1 2)) (y . (3 4)) (z . (5 6)))))} | |
165 @code{((x . 2) (y . 4) (z . 6))}" | |
166 (map | |
167 (lambda (row) (cons (car row) (assoc-get column (cdr row)))) | |
168 spreadsheet)) | |
169 | |
170 ; More this-file specific utility functions | |
171 ; (ie not really useful anywhere else) | |
172 | |
173 (define (bezier-head-for-stencil bezier cut-point) | |
174 "Prepares a split-bezier to be used in a connected shape stencil." | |
175 (list-tail (flatten-list (car (split-bezier bezier cut-point))) 2)) | |
176 | |
177 ;Makes the alist used to generate woodwind-data-alist. | |
Neil Puttock
2010/05/31 14:48:13
move inside function
| |
178 (define make-key-alist | |
179 (make-named-spreadsheet '(name offset graphical textual))) | |
180 | |
181 (define (simple-stencil-alist stencil offset) | |
182 "A stencil alist that contains one and only one stencil. | |
183 Shorthand used repeatedly in various instruments." | |
184 `((stencils . (,stencil)) | |
185 (offset . ,offset) | |
186 (textual? . #f) | |
187 (xy-scale-function . (,return-1 . ,return-1)))) | |
188 | |
189 (define (make-central-column-hole-addresses keys) | |
190 "Takes @code{keys} and ascribes them to the central column." | |
191 (map | |
192 (lambda (key) `(central-column . ,key)) | |
193 keys)) | |
194 | |
195 (define (make-key-symbols hand) | |
196 "Takes @code{hand} and ascribes @code{key} to it." | |
197 (lambda (keys) | |
198 (map | |
199 (lambda (key) `(,hand . ,key)) | |
200 keys))) | |
201 | |
202 (define make-left-hand-key-addresses (make-key-symbols 'left-hand)) | |
203 | |
204 (define make-right-hand-key-addresses (make-key-symbols 'right-hand)) | |
205 | |
206 ;; Translators for keys | |
207 | |
208 ; Translates a "normal" key (open, closed, trill) | |
209 (define (key-fill-translate fill) | |
210 (cond | |
211 ((= fill 1) #f) | |
212 ((= fill 2) #f) | |
213 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) | |
214 ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t))) | |
215 | |
216 ; Similar to above, but trans vs opaque doesn't matter | |
217 (define (text-fill-translate fill) | |
218 (cond | |
219 ((< fill 3) 1.0) | |
220 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) | |
221 ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0))) | |
222 | |
223 ; Emits a list for the central-column-hole maker | |
224 ; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?) | |
225 ; Multiple values, such as (#t #f #f #t #f), mean a trill between | |
226 ; not-full and 3-quarters-full | |
227 (define (process-fill-value fill) | |
228 (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1))) | |
229 (append `(,(or (< fill 3) (is-square? fill avals))) | |
230 (map (lambda (x) (= 0 (remainder fill x))) avals)))) | |
231 | |
232 ; Color a stencil gray | |
233 (define (gray-colorize stencil) | |
234 (ly:stencil-in-color stencil 0.5 0.5 0.5)) | |
Neil Puttock
2010/05/31 14:48:13
(ly:stencil-in-color stencil grey))
| |
235 | |
236 ; A connected shape stencil that is surrounded by proc | |
237 (define (rich-mcs-stencil ls x-stretch y-stretch proc) | |
238 (lambda | |
239 (radius thick fill layout props) | |
240 (let* | |
241 ((fill-translate (key-fill-translate fill)) | |
242 (gray? (eqv? fill-translate 0.5))) | |
243 (ly:stencil-add | |
244 ((if gray? gray-colorize return-x) | |
245 (proc | |
246 (make-connected-shape-stencil | |
247 ls | |
248 thick | |
249 (* x-stretch radius) | |
250 (* y-stretch radius) | |
251 #f | |
252 (if gray? #t fill-translate)))) | |
253 (if (not gray?) | |
254 empty-stencil | |
255 ((rich-mcs-stencil ls x-stretch y-stretch proc) | |
256 radius | |
257 thick | |
258 1 | |
259 layout | |
260 props)))))) | |
261 | |
262 ; A connected shape stencil without a surrounding proc | |
263 (define (standard-mcs-stencil ls x-stretch y-stretch) | |
264 (rich-mcs-stencil ls x-stretch y-stretch return-x)) | |
265 | |
266 ; An ellipse stencil that is surrounded by a proc | |
267 (define (rich-pe-stencil x-stretch y-stretch start end proc) | |
268 (lambda | |
269 (radius thick fill layout props) | |
270 (let* | |
271 ((fill-translate (key-fill-translate fill)) | |
272 (gray? (eqv? fill-translate 0.5))) | |
273 (ly:stencil-add | |
274 ((if gray? gray-colorize return-x) | |
275 (proc | |
276 (make-partial-ellipse-stencil | |
277 (* x-stretch radius) | |
278 (* y-stretch radius) | |
279 start | |
280 end | |
281 thick | |
282 #t | |
283 (if gray? #t fill-translate)))) | |
284 (if (not gray?) | |
285 empty-stencil | |
286 ((rich-pe-stencil x-stretch y-stretch start end proc) | |
287 radius | |
288 thick | |
289 1 | |
290 layout | |
291 props)))))) | |
292 | |
293 (define (rich-e-stencil x-stretch y-stretch proc) | |
294 (lambda | |
295 (radius thick fill layout props) | |
296 (let* | |
297 ((fill-translate (key-fill-translate fill)) | |
298 (gray? (eqv? fill-translate 0.5))) | |
299 (ly:stencil-add | |
300 ((if gray? gray-colorize return-x) | |
301 (proc | |
302 (make-ellipse-stencil | |
303 (* x-stretch radius) | |
304 (* y-stretch radius) | |
305 thick | |
306 (if gray? #t fill-translate)))) | |
307 (if (not gray?) | |
308 empty-stencil | |
309 ((rich-e-stencil x-stretch y-stretch proc) | |
310 radius | |
311 thick | |
312 1 | |
313 layout | |
314 props)))))) | |
315 | |
316 ; An ellipse stencil without a surrounding proc | |
317 (define (standard-e-stencil x-stretch y-stretch) | |
318 (rich-e-stencil x-stretch y-stretch return-x)) | |
319 | |
320 ; Translates all possible representations of symbol. | |
321 ; If simple? then the only representations are open, closed, and trill. | |
322 ; Otherwise, there can be various levels of "closure" on the holes | |
323 ; ring? allows for a ring around the holes as well | |
324 (define (make-symbol-alist symbol simple? ring?) | |
325 (filter | |
326 (lambda | |
327 (x) | |
328 (not | |
329 (equal? | |
330 x | |
331 `(,(symbol-concatenate symbol 'T 'F) . | |
332 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))))) | |
333 (append | |
334 `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST)) | |
335 (,(symbol-concatenate symbol 'T) . | |
336 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))) | |
337 (if simple? | |
338 '() | |
339 (apply append | |
340 (map | |
341 (lambda | |
342 (x) | |
343 (append | |
344 `((,(symbol-concatenate symbol (car x) 'T) . | |
345 ,(expt (cdr x) 2)) | |
346 (,(symbol-concatenate symbol 'T (car x)) . | |
347 ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST))) | |
348 (,(symbol-concatenate symbol (car x)) . ,(cdr x))) | |
349 (apply append | |
350 (map | |
351 (lambda | |
352 (y) | |
353 (map | |
354 (lambda | |
355 (a b) | |
356 `(,(symbol-concatenate symbol (car a) 'T (car b)) . | |
357 ,(* (cdr a) (cdr b)))) | |
358 `(,x ,y) `(,y ,x))) | |
359 (cdr (member x HOLE-FILL-LIST)))))) | |
360 (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST)))))))) | |
361 | |
362 ;;; Commands for text layout | |
363 | |
364 ; Draws a circle around markup if (= trigger 0.5) | |
365 (define-markup-command | |
366 (conditional-circle-markup layout props trigger in-markup) | |
367 (number? markup?) | |
368 (interpret-markup layout props | |
369 (if (eqv? trigger 0.5) | |
370 (markup #:circle (markup in-markup)) | |
371 (markup in-markup)))) | |
372 | |
373 ; Makes a list of named-keys | |
374 (define (make-name-keylist input-list key-list font-size) | |
375 (map (lambda (x y) | |
376 (if (< x 1) | |
377 (markup #:conditional-circle-markup | |
378 x | |
379 (make-concat-markup | |
380 (list | |
381 (markup #:abs-fontsize font-size (car y)) | |
382 (if (and (< x 1) (cdr y)) | |
383 (if (eqv? (cdr y) 1) | |
384 (markup | |
385 #:abs-fontsize | |
386 font-size | |
387 #:raise | |
388 1 | |
389 #:fontsize | |
390 -2 | |
391 #:sharp) | |
392 (markup | |
393 #:abs-fontsize | |
394 font-size | |
395 #:raise | |
396 1 | |
397 #:fontsize | |
398 -2 | |
399 #:flat)) | |
400 (markup #:null))))) | |
401 (markup #:null))) | |
402 input-list key-list)) | |
403 | |
404 ; Makes a list of number-keys | |
405 (define (make-number-keylist input-list key-list font-size) | |
406 (map | |
407 (lambda (x y) | |
408 (if (< x 1) | |
409 (markup | |
410 #:conditional-circle-markup | |
411 x | |
412 (markup #:abs-fontsize font-size #:number y)) | |
413 (markup #:null))) | |
414 input-list | |
415 key-list)) | |
416 | |
417 ; Creates a named-key list with a certain alignment | |
418 (define (aligned-text-stencil-function dir hv) | |
419 (lambda (key-name-list radius fill-list layout props) | |
420 (ly:text-interface::interpret-markup | |
Neil Puttock
2010/05/31 14:48:13
interpret-markup
| |
421 layout | |
422 props | |
423 (make-general-align-markup | |
424 X | |
425 dir | |
426 ((if hv make-concat-markup make-center-column-markup) | |
427 (make-name-keylist | |
428 (map text-fill-translate fill-list) | |
429 key-name-list | |
430 (* 12 radius))))))) | |
431 | |
432 (define number-column-stencil | |
433 (lambda (key-name-list radius fill-list layout props) | |
434 (ly:text-interface::interpret-markup | |
Neil Puttock
2010/05/31 14:48:13
interpret-markup
| |
435 layout | |
436 props | |
437 (make-general-align-markup | |
438 Y | |
439 CENTER | |
440 (make-general-align-markup | |
441 X | |
442 RIGHT | |
443 (make-override-markup | |
444 '(baseline-skip . 0) | |
445 (make-column-markup | |
446 (make-number-keylist | |
447 (map text-fill-translate fill-list) | |
448 key-name-list | |
449 (* radius 8))))))))) | |
450 | |
451 ; Utility function for the left-hand keys | |
452 (define lh-woodwind-text-stencil | |
453 (aligned-text-stencil-function LEFT #t)) | |
454 | |
455 ; Utility function for the right-hand keys | |
456 (define rh-woodwind-text-stencil | |
457 (aligned-text-stencil-function RIGHT #t)) | |
458 | |
459 (define octave-woodwind-text-stencil | |
460 (aligned-text-stencil-function CENTER #f)) | |
461 | |
462 ;;; Draw rules | |
463 | |
464 (define (rich-group-draw-rule alist target-part change-part) | |
465 (if | |
466 (entry-greater-than-x? | |
467 (map (lambda (key) (assoc-get key alist)) target-part) 3) | |
468 (map-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist) | |
469 alist)) | |
470 | |
471 (define (bassoon-midline-rule alist target-part) | |
472 (if | |
473 (entry-greater-than-x? | |
474 (map (lambda (key) (assoc-get key alist)) target-part) 0) | |
475 (map-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist) | |
476 (map-alist-keys (lambda (x) 1) '((hidden . midline)) alist))) | |
477 | |
478 (define (group-draw-rule alist target-part) | |
479 (rich-group-draw-rule alist target-part target-part)) | |
480 | |
481 (define (group-automate-rule alist change-part) | |
482 (map-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist)) | |
483 | |
484 (define (apply-group-draw-rule-series alist target-part-list) | |
485 (if (null? target-part-list) | |
486 alist | |
487 (apply-group-draw-rule-series | |
488 (group-draw-rule alist (car target-part-list)) | |
489 (cdr target-part-list)))) | |
490 | |
491 ;; Extra-offset rules | |
492 | |
493 (define (rich-group-extra-offset-rule alist target-part change-part eos) | |
494 (if | |
495 (entry-greater-than-x? | |
496 (map (lambda (key) (assoc-get key alist)) target-part) 0) | |
497 (map-alist-keys (lambda (x) eos) change-part alist) | |
498 alist)) | |
499 | |
500 (define (group-extra-offset-rule alist target-part eos) | |
501 (rich-group-extra-offset-rule alist target-part target-part eos)) | |
502 | |
503 (define (uniform-extra-offset-rule alist eos) | |
504 (map-alist-keys | |
505 (lambda (x) (if (pair? x) x eos)) | |
506 (assoc-keys alist) | |
507 alist)) | |
508 | |
509 ;;; General drawing commands | |
510 | |
511 ; Used all the time for a dividing line | |
512 (define (midline-stencil radius thick fill layout props) | |
513 (make-line-stencil (* thick 2) (* -0.75 radius) 0 (* 0.75 radius) 0)) | |
514 | |
515 (define (long-midline-stencil radius thick fill layout props) | |
516 (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0)) | |
517 | |
518 ; Used all the time for a small, between-hole key | |
519 (define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2)) | |
520 | |
521 ; Used for several upper keys in the clarinet and sax | |
522 (define (upper-key-stencil tailw tailh bodyw bodyh) | |
523 (let* | |
524 ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2)))))) | |
525 (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05))))))) | |
526 (standard-mcs-stencil | |
527 `((,(xmove 0.7) | |
528 ,(ymove -0.2) | |
529 ,(xmove 1.0) | |
530 ,(ymove -1.0) | |
531 ,(xmove 0.5) | |
532 ,(ymove -1.0)) | |
533 (,(xmove 0.2) | |
534 ,(ymove -1.0) | |
535 ,(xmove 0.2) | |
536 ,(ymove -0.2) | |
537 ,(xmove 0.3) | |
538 ,(ymove -0.1)) | |
539 (,(+ 0.2 tailw) | |
540 ,(- -0.05 tailh) | |
541 ,(+ 0.1 (/ tailw 2)) | |
542 ,(- -0.025 (/ tailh 2)) | |
543 0.0 | |
544 0.0)) | |
545 1.0 | |
546 1.0))) | |
547 | |
548 ; Utility function for the column-hole maker. | |
549 ; Returns the left and right degrees for the drawing of a given | |
550 ; fill level (1-quarter, 1-half, etc...) | |
551 (define (degree-first-true fill-list left? reverse?) | |
552 (define (dfl-crawler fill-list os-list left?) | |
553 (if (car fill-list) | |
554 ((if left? car cdr) (car os-list)) | |
555 (dfl-crawler (cdr fill-list) (cdr os-list) left?))) | |
556 (dfl-crawler | |
557 ((if reverse? reverse return-x) fill-list) | |
558 ((if reverse? reverse return-x) | |
559 '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90))) | |
560 left?)) | |
561 | |
562 ; Gets the position of the first (or last if reverse?) element of a list. | |
563 (define (position-true-endpoint in-list reverse?) | |
564 (define (pte-crawler in-list n) | |
565 (if (car in-list) | |
566 n | |
567 (pte-crawler (cdr in-list) (+ n 1)))) | |
568 ((if reverse? - +) | |
569 (if reverse? (length in-list) 0) | |
570 (pte-crawler ((if reverse? reverse return-x) in-list) 0))) | |
571 | |
572 ; Huge, kind-of-ugly maker of a circle in a column. | |
573 ; I think this is the clearest way to write it, though... | |
574 | |
575 (define (column-circle-stencil radius thick fill layout props) | |
576 (let* ((fill-list (process-fill-value fill))) | |
577 (cond | |
578 ((and | |
579 (list-ref fill-list 0) | |
580 (not (true-entry? (list-tail fill-list 1)))) ; is it empty? | |
581 ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) | |
582 ((and | |
583 (list-ref fill-list 4) | |
584 (not (true-entry? (list-head fill-list 4)))) ; is it full? | |
585 ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) | |
586 ((and | |
587 (list-ref fill-list 0) | |
588 (list-ref fill-list 4)) ; is it a trill between empty and full? | |
589 ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) | |
590 (else ;If none of these, it is partially full. | |
591 (ly:stencil-add | |
592 ((rich-pe-stencil 1.0 1.0 0 360 return-x) | |
593 radius | |
594 thick | |
595 (if (list-ref fill-list 4) | |
596 (expt (assoc-get 'F HOLE-FILL-LIST) 2) | |
597 1) | |
598 layout | |
599 props) | |
600 ((rich-pe-stencil | |
601 1.0 | |
602 1.0 | |
603 (degree-first-true fill-list #t #t) | |
604 (degree-first-true fill-list #f #t) | |
605 return-x) | |
606 radius | |
607 thick | |
608 (if | |
609 (true-entry? | |
610 (list-head fill-list (position-true-endpoint fill-list #t))) | |
611 (expt (assoc-get 'F HOLE-FILL-LIST) 2) | |
612 (assoc-get 'F HOLE-FILL-LIST)) | |
613 layout | |
614 props) | |
615 (if | |
616 (= 2 (n-true-entries (list-tail fill-list 1))) ; trill? | |
617 ((rich-pe-stencil | |
618 1.0 | |
619 1.0 | |
620 (degree-first-true fill-list #t #f) | |
621 (degree-first-true fill-list #f #f) | |
622 return-x) | |
623 radius | |
624 thick | |
625 (assoc-get 'F HOLE-FILL-LIST) | |
626 layout | |
627 props) | |
628 empty-stencil)))))) | |
629 | |
630 (define (variable-column-circle-stencil scaler) | |
631 (lambda | |
632 (radius thick fill layout props) | |
633 (column-circle-stencil (* radius scaler) thick fill layout props))) | |
634 | |
635 ; A stencil for ring-column circles that combines two of the above | |
636 (define (ring-column-circle-stencil radius thick fill layout props) | |
637 (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST))) | |
638 (ly:stencil-add | |
639 ((if | |
640 (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) | |
641 gray-colorize | |
642 return-x) | |
643 ((standard-e-stencil | |
644 (* (+ (- 1.0 (* 2 thick)) (/ thick 2))) | |
645 (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))) | |
646 radius | |
647 (* (* 4 radius) thick) | |
648 1 | |
649 layout | |
650 props)) | |
651 ((standard-e-stencil 1.0 1.0) radius thick 1 layout props) | |
652 (column-circle-stencil | |
653 (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2)) | |
654 thick | |
655 (* | |
656 (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST))) | |
657 (assoc-get 'F HOLE-FILL-LIST) | |
658 1) | |
659 (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) | |
660 (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) | |
661 (/ fill (assoc-get 'R HOLE-FILL-LIST)))) | |
662 layout | |
663 props)) | |
664 (column-circle-stencil radius thick fill layout props))) | |
665 | |
666 ;;; Flute family stencils | |
667 | |
668 (define flute-lh-b-key-stencil | |
669 (standard-mcs-stencil | |
670 '((0 1.3) | |
671 (0 1.625 -0.125 1.75 -0.25 1.75) | |
672 (-0.55 1.75 -0.55 0.95 -0.25 0.7) | |
673 (0 0.4 0 0.125 0 0)) | |
674 2 | |
675 1.55)) | |
676 | |
677 (define flute-lh-bes-key-stencil | |
678 (standard-mcs-stencil | |
679 '((0 1.3) | |
680 (0 1.625 -0.125 1.75 -0.25 1.75) | |
681 (-0.55 1.75 -0.55 0.95 -0.25 0.7) | |
682 (0 0.4 0 0.125 0 0)) | |
683 2.0 | |
684 1.3)) | |
685 | |
686 (define (flute-lh-gis-rh-bes-key-stencil deg) | |
687 (rich-mcs-stencil | |
688 '((0.1 0.1 0.2 0.4 0.3 0.6) | |
689 (0.3 1.0 0.8 1.0 0.8 0.7) | |
690 (0.8 0.3 0.5 0.3 0 0)) | |
691 1.0 | |
692 1.0 | |
693 (lambda (stencil) (ly:stencil-rotate stencil deg 0 0)))) | |
694 | |
695 (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0)) | |
696 | |
697 (define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200)) | |
698 | |
699 (define flute-rh-d-key-stencil little-elliptical-key-stencil) | |
700 | |
701 (define flute-rh-dis-key-stencil little-elliptical-key-stencil) | |
702 | |
703 (define flute-rh-ees-key-stencil | |
704 (standard-mcs-stencil | |
705 '((0.8 0) (1.1 0 1.1 0.75 0.7 0.75) (0.5 0.75) (0.15 0.75 0.1 0.2 0 0)) | |
706 -2.38 | |
707 1.4)) | |
708 | |
709 (define (piccolo-rh-x-key-stencil radius thick fill layout props) | |
710 (ly:text-interface::interpret-markup | |
711 layout | |
712 props | |
713 (make-general-align-markup | |
714 Y | |
715 DOWN | |
716 (make-concat-markup | |
717 (make-name-keylist | |
718 `(,(text-fill-translate fill)) | |
719 '(("X" . #f)) | |
720 (* 9 radius)))))) | |
721 | |
722 (define flute-lower-row-stretch 1.4) | |
723 | |
724 (define flute-rh-cis-key-stencil | |
725 (standard-mcs-stencil | |
726 '((0 0.75) (-0.8 0.75 -0.8 0 0 0)) | |
727 flute-lower-row-stretch | |
728 flute-lower-row-stretch)) | |
729 | |
730 (define flute-rh-c-key-stencil | |
731 (standard-mcs-stencil | |
732 '((0 0.75) (0.4 0.75) (0.4 0) (0 0)) | |
733 flute-lower-row-stretch | |
734 flute-lower-row-stretch)) | |
735 | |
736 (define flute-rh-b-key-stencil | |
737 (standard-mcs-stencil | |
738 '((0 0.75) (0.25 0.75) (0.25 0) (0 0)) | |
739 flute-lower-row-stretch | |
740 flute-lower-row-stretch)) | |
741 | |
742 (define flute-rh-gz-key-stencil | |
743 (rich-mcs-stencil | |
744 '((0.1 0.1 0.4 0.2 0.6 0.3) | |
745 (1.0 0.3 1.0 0.8 0.7 0.8) | |
746 (0.3 0.8 0.3 0.5 0 0)) | |
747 flute-lower-row-stretch | |
748 flute-lower-row-stretch | |
749 (lambda (stencil) (ly:stencil-rotate stencil 160 0 0)))) | |
750 | |
751 (define flute-change-points | |
752 ((make-named-spreadsheet '(piccolo flute)) | |
753 `((bottom-group-key-names . | |
754 (((x . | |
755 ((offset . (-0.45 . -1.05)) | |
756 (stencil . ,piccolo-rh-x-key-stencil) | |
757 (text? . ("X" . #f)) | |
758 (complexity . trill)))) | |
759 ((cis . | |
760 ((offset . (0.0 . 0.0)) | |
761 (stencil . ,flute-rh-cis-key-stencil) | |
762 (text? . ("C" . 1)) | |
763 (complexity . trill))) | |
764 (c . | |
765 ((offset . (0.3 . 0.0)) | |
766 (stencil . ,flute-rh-c-key-stencil) | |
767 (text? . ("C" . #f)) | |
768 (complexity . trill))) | |
769 (b . | |
770 ((offset . (1.0 . 0.0)) | |
771 (stencil . ,flute-rh-b-key-stencil) | |
772 (text? . ("B" . #f)) | |
773 (complexity . trill))) | |
774 (gz . | |
775 ((offset . (0.0 . -1.2)) | |
776 (stencil . ,flute-rh-gz-key-stencil) | |
777 (text? . ("gz" . #f)) | |
778 (complexity . trill)))))) | |
779 (bottom-group-graphical-stencil . | |
780 (((right-hand . ees) (right-hand . x)) | |
781 ,(make-right-hand-key-addresses '(ees cis c b gz)))) | |
782 (bottom-group-graphical-draw-instruction . | |
783 (((right-hand . ees)) | |
784 ,(make-right-hand-key-addresses '(ees cis c b)))) | |
785 (bottom-group-special-key-instruction . | |
786 ((,rich-group-draw-rule | |
787 ((right-hand . x)) | |
788 ((right-hand . ees))) | |
789 (,rich-group-draw-rule | |
790 ((right-hand . gz)) | |
791 ,(make-right-hand-key-addresses '(ees cis c b))))) | |
792 (bottom-group-text-stencil . | |
793 (,(make-right-hand-key-addresses '(bes d dis ees x)) | |
794 ,(make-right-hand-key-addresses '(bes d dis ees cis c b gz)))) | |
795 (bottom-group-text-draw-instruction . | |
796 (,(make-right-hand-key-addresses '(bes d dis ees x)) | |
797 ,(make-right-hand-key-addresses '(bes d dis ees cis c b gz))))))) | |
798 | |
799 (define (generate-flute-family-entry flute-name) | |
Neil Puttock
2010/05/31 14:48:13
I think it might be better to move these alists to
| |
800 (let* | |
801 ((change-points | |
802 (get-named-spreadsheet-column | |
803 flute-name | |
804 flute-change-points))) | |
805 `(,flute-name . | |
Neil Puttock
2010/05/31 14:48:13
`(,flute-name
. (
etc.
(see scm/define-grobs.s
| |
806 ((keys . | |
807 ((hidden . | |
808 ((midline . | |
809 ((offset . (0.0 . 0.0)) | |
810 (stencil . ,midline-stencil) | |
811 (text? . #f) | |
812 (complexity . basic))))) | |
813 (central-column . | |
814 ((one . | |
815 ((offset . (0.0 . 1.0)) | |
816 (stencil . ,ring-column-circle-stencil) | |
817 (text? . #f) | |
818 (complexity . ring))) | |
819 (two . | |
820 ((offset . (0.0 . 2.0)) | |
821 (stencil . ,ring-column-circle-stencil) | |
822 (text? . #f) | |
823 (complexity . ring))) | |
824 (three . | |
825 ((offset . (0.0 . 3.0)) | |
826 (stencil . ,ring-column-circle-stencil) | |
827 (text? . #f) | |
828 (complexity . ring))) | |
829 (four . | |
830 ((offset . (0.0 . 4.5)) | |
831 (stencil . ,ring-column-circle-stencil) | |
832 (text? . #f) | |
833 (complexity . ring))) | |
834 (five . | |
835 ((offset . (0.0 . 5.5)) | |
836 (stencil . ,ring-column-circle-stencil) | |
837 (text? . #f) | |
838 (complexity . ring))) | |
839 (six . | |
840 ((offset . (0.0 . 6.5)) | |
841 (stencil . ,ring-column-circle-stencil) | |
842 (text? . #f) | |
843 (complexity . ring))))) | |
844 (left-hand . | |
845 ((bes . | |
846 ((offset . (0.5 . 1.8)) | |
847 (stencil . ,flute-lh-bes-key-stencil) | |
848 (text? . ("B" . 0)) | |
849 (complexity . trill))) | |
850 (b . | |
851 ((offset . (0.0 . 0.0)) | |
852 (stencil . ,flute-lh-b-key-stencil) | |
853 (text? . ("B" . #f)) | |
854 (complexity . trill))) | |
855 (gis . | |
856 ((offset . (0.0 . 0.0)) | |
857 (stencil . ,flute-lh-gis-key-stencil) | |
858 (text? . ("G" . 1)) | |
859 (complexity . trill))))) | |
860 (right-hand . | |
861 ,(append | |
862 `((bes . | |
863 ((offset . (0.0 . 0.0)) | |
864 (stencil . ,flute-rh-bes-key-stencil) | |
865 (text? . ("B" . 0)) | |
866 (complexity . trill))) | |
867 (d . | |
868 ((offset . (0.0 . 0.0)) | |
869 (stencil . ,flute-rh-d-key-stencil) | |
870 (text? . ("D" . #f)) | |
871 (complexity . trill))) | |
872 (dis . | |
873 ((offset . (0.0 . 0.0)) | |
874 (stencil . ,flute-rh-dis-key-stencil) | |
875 (text? . ("D" . 1)) | |
876 (complexity . trill))) | |
877 (ees . | |
878 ((offset . (1.5 . 1.3)) | |
879 (stencil . ,flute-rh-ees-key-stencil) | |
880 (text? . ("E" . 0)) | |
881 (complexity . trill)))) | |
882 (assoc-get 'bottom-group-key-names change-points))))) | |
883 (graphical-commands . | |
884 ((stencil-alist . | |
885 ((stencils . | |
886 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
887 ((stencils . | |
888 ,(make-central-column-hole-addresses | |
889 '(one two three four five six))) | |
890 (xy-scale-function . (,return-x . ,return-x)) | |
891 (textual? . #f) | |
892 (offset . (0.0 . 0.0))) | |
893 ((stencils . | |
894 ((left-hand . bes) (left-hand . b))) | |
895 (xy-scale-function . (,return-1 . ,return-1)) | |
896 (textual? . #f) | |
897 (offset . (-1.5 . 6.5))) | |
898 ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0)) | |
899 ,(simple-stencil-alist '(right-hand . bes) '(-1.75 . 3.05)) | |
900 ,(simple-stencil-alist '(right-hand . d) '(-1.0 . 2.5)) | |
901 ,(simple-stencil-alist '(right-hand . dis) '(-1.0 . 1.5)) | |
902 ((stencils . | |
903 ,(assoc-get 'bottom-group-graphical-stencil change-points)) | |
904 (xy-scale-function . (,return-1 . ,return-1)) | |
905 (textual? . #f) | |
906 (offset . (0.0 . -0.6))))) | |
907 (xy-scale-function . (,return-x . ,return-x)) | |
908 (textual? . #f) | |
909 (offset . (0.0 . 0.0)))) | |
910 (draw-instructions . | |
911 ((,apply-group-draw-rule-series | |
912 (((left-hand . bes) (left-hand . b)) | |
913 ,(assoc-get 'bottom-group-graphical-draw-instruction change-points))) | |
914 ,(assoc-get 'bottom-group-special-key-instruction change-points) | |
915 (,group-automate-rule | |
916 ,(make-central-column-hole-addresses '(one two three four five six))) | |
917 (,group-automate-rule ((hidden . midline))))) | |
918 (extra-offset-instructions . | |
919 ((,uniform-extra-offset-rule (0.0 . 0.0)))))) | |
920 (text-commands . | |
921 ((stencil-alist . | |
922 ((stencils . | |
923 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
924 ((stencils . | |
925 ,(make-central-column-hole-addresses | |
926 '(one two three four five six))) | |
927 (xy-scale-function . (,return-x . ,return-x)) | |
928 (textual? . #f) | |
929 (offset . (0.0 . 0.0))) | |
930 ((stencils . ,(make-left-hand-key-addresses '(bes b gis))) | |
931 (textual? . ,lh-woodwind-text-stencil) | |
932 (offset . (1.5 . 3.75))) | |
933 ((stencils . ,(assoc-get 'bottom-group-text-stencil change-points)) | |
934 (textual? . ,rh-woodwind-text-stencil) | |
935 (offset . (-1.25 . 0.0))))) | |
936 (xy-scale-function . (,return-x . ,return-x)) | |
937 (textual? . #f) | |
938 (offset . (0.0 . 0.0)))) | |
939 (draw-instructions . | |
940 ((,apply-group-draw-rule-series | |
941 (,(make-left-hand-key-addresses '(bes b gis)) | |
942 ,(assoc-get 'bottom-group-text-draw-instruction change-points))) | |
943 (,group-automate-rule | |
944 ,(make-central-column-hole-addresses '(one two three four five six))) | |
945 (,group-automate-rule ((hidden . midline))))) | |
946 (extra-offset-instructions . | |
947 ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) | |
948 | |
949 ;;; Shared oboe/clarinet stencils | |
950 | |
951 (define (oboe-lh-gis-lh-low-b-key-stencil gis?) | |
952 (let* | |
953 ((x 1.2) | |
954 (y 0.4) | |
955 (scaling-factor 1.7) | |
956 (up-part | |
957 (car | |
958 (split-bezier | |
959 `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0)) | |
960 0.8))) | |
961 (down-part | |
962 (cdr | |
963 (split-bezier | |
964 `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0)) | |
965 0.2)))) | |
966 (if gis? | |
967 (standard-mcs-stencil | |
968 (append | |
969 (append `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0)) | |
970 (map | |
971 (lambda | |
972 (l) | |
973 (flatten-list | |
974 (map | |
975 (lambda | |
976 (x) | |
977 (interval-translate | |
978 (interval-rotate x (atan (/ y (* 2 0.25)))) '(1.0 . 0))) | |
979 l))) | |
980 `(((0 . ,y) (,x . ,y) (,x . 0)) | |
981 ((,x . ,(- y)) (0 . ,(- y)) (0 . 0))))) | |
982 `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0))) | |
983 scaling-factor | |
984 scaling-factor) | |
985 (standard-mcs-stencil | |
986 (map | |
987 (lambda | |
988 (l) | |
989 (flatten-list | |
990 (map | |
991 (lambda | |
992 (x) | |
993 (interval-rotate x (atan (/ y (* 2 0.25))))) | |
994 l))) | |
995 `(,(list-tail up-part 1) | |
996 ,(list-head down-part 1) | |
997 ,(list-tail down-part 1))) | |
998 (- scaling-factor) | |
999 (- scaling-factor))))) | |
1000 | |
1001 (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t)) | |
1002 | |
1003 (define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f)) | |
1004 | |
1005 (define (oboe-lh-ees-lh-bes-key-stencil ees?) | |
1006 (standard-mcs-stencil | |
1007 `((0 1.5) | |
1008 (0 1.625 -0.125 1.75 -0.25 1.75) | |
1009 (-0.5 1.75 -0.5 0.816 -0.25 0.5) | |
1010 (0 0.25 0 0.125 0 0) | |
1011 (0 ,(if ees? -0.6 -0.3))) | |
1012 (* (if ees? -1.0 1.0) -1.8) | |
1013 1.8)) | |
1014 | |
1015 (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t)) | |
1016 | |
1017 (define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f)) | |
1018 | |
1019 ;;; Oboe family stencils | |
1020 | |
1021 (define (oboe-lh-octave-key-stencil long?) | |
1022 (let* ((h (if long? 1.4 1.2))) | |
1023 (standard-mcs-stencil | |
1024 `((-0.4 0 -0.4 1.0 -0.1 1.0) | |
1025 (-0.1 ,h) | |
1026 (0.1 ,h) | |
1027 (0.1 1.0) | |
1028 (0.4 1.0 0.4 0 0 0)) | |
1029 2.0 | |
1030 2.0))) | |
1031 | |
1032 (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f)) | |
1033 | |
1034 (define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f)) | |
1035 | |
1036 (define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t)) | |
1037 | |
1038 (define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8)) | |
1039 | |
1040 (define oboe-lh-d-key-stencil little-elliptical-key-stencil) | |
1041 | |
1042 (define oboe-lh-cis-key-stencil little-elliptical-key-stencil) | |
1043 | |
1044 (define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0)) | |
1045 | |
1046 (define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45)) | |
1047 | |
1048 (define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2)) | |
1049 | |
1050 (define oboe-rh-d-key-stencil little-elliptical-key-stencil) | |
1051 | |
1052 (define oboe-rh-f-key-stencil little-elliptical-key-stencil) | |
1053 | |
1054 (define (oboe-rh-c-rh-ees-key-stencil c?) | |
1055 (rich-mcs-stencil | |
1056 '((1.0 0.0 1.0 0.70 1.5 0.70) | |
1057 (2.25 0.70 2.25 -0.4 1.5 -0.4) | |
1058 (1.0 -0.4 1.0 0 0 0) | |
1059 (-0.15 0)) | |
1060 2.0 | |
1061 1.4 | |
1062 (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0)))) | |
1063 | |
1064 (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil) | |
1065 | |
1066 (define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t)) | |
1067 | |
1068 (define oboe-rh-cis-key-stencil | |
1069 (rich-mcs-stencil | |
1070 '((0.6 0.0 0.6 0.50 1.25 0.50) | |
1071 (2.25 0.50 2.25 -0.4 1.25 -0.4) | |
1072 (0.6 -0.4 0.6 0 0 0)) | |
1073 -0.9 | |
1074 1.0 | |
1075 (lambda (stencil) (ly:stencil-rotate stencil 0 0 0)))) | |
1076 | |
1077 (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f)) | |
1078 | |
1079 (define oboe-change-points | |
1080 ((make-named-spreadsheet '(oboe)) '())) | |
1081 | |
1082 (define (generate-oboe-family-entry oboe-name) | |
1083 (let* | |
1084 ((change-points | |
1085 (get-named-spreadsheet-column oboe-name oboe-change-points))) | |
1086 `(,oboe-name . | |
1087 ((keys . | |
1088 ((hidden . | |
1089 ((midline . | |
1090 ((offset . (0.0 . 0.0)) | |
1091 (stencil . ,midline-stencil) | |
1092 (text? . #f) | |
1093 (complexity . basic))))) | |
1094 (central-column . | |
1095 ((one . | |
1096 ((offset . (0.0 . 1.0)) | |
1097 (stencil . ,ring-column-circle-stencil) | |
1098 (text? . #f) | |
1099 (complexity . ring))) | |
1100 (two . | |
1101 ((offset . (0.0 . 2.0)) | |
1102 (stencil . ,ring-column-circle-stencil) | |
1103 (text? . #f) | |
1104 (complexity . ring))) | |
1105 (three . | |
1106 ((offset . (0.0 . 3.0)) | |
1107 (stencil . ,ring-column-circle-stencil) | |
1108 (text? . #f) | |
1109 (complexity . ring))) | |
1110 (four . | |
1111 ((offset . (0.0 . 4.5)) | |
1112 (stencil . ,ring-column-circle-stencil) | |
1113 (text? . #f) | |
1114 (complexity . ring))) | |
1115 (five . | |
1116 ((offset . (0.0 . 5.5)) | |
1117 (stencil . ,ring-column-circle-stencil) | |
1118 (text? . #f) | |
1119 (complexity . ring))) | |
1120 (six . | |
1121 ((offset . (0.0 . 6.5)) | |
1122 (stencil . ,ring-column-circle-stencil) | |
1123 (text? . #f) | |
1124 (complexity . ring))) | |
1125 (h . | |
1126 ((offset . (0.0 . 6.25)) | |
1127 (stencil . ,(variable-column-circle-stencil 0.4)) | |
1128 (text? . #f) | |
1129 (complexity . trill))))) | |
1130 (left-hand . | |
1131 ((I . | |
1132 ((offset . (0.0 . 0.0)) | |
1133 (stencil . ,oboe-lh-I-key-stencil) | |
1134 (text? . ("I" . #f)) | |
1135 (complexity . trill))) | |
1136 (III . | |
1137 ((offset . (0.0 . 2.6)) | |
1138 (stencil . ,oboe-lh-III-key-stencil) | |
1139 (text? . ("III" . #f)) | |
1140 (complexity . trill))) | |
1141 (II . | |
1142 ((offset . (0.0 . 0.0)) | |
1143 (stencil . ,oboe-lh-II-key-stencil) | |
1144 (text? . ("II" . #f)) | |
1145 (complexity . trill))) | |
1146 (b . | |
1147 ((offset . (0.0 . 0.0)) | |
1148 (stencil . ,oboe-lh-b-key-stencil) | |
1149 (text? . ("B" . #f)) | |
1150 (complexity . trill))) | |
1151 (d . | |
1152 ((offset . (0.0 . 0.0)) | |
1153 (stencil . ,oboe-lh-d-key-stencil) | |
1154 (text? . ("D" . #f)) | |
1155 (complexity . trill))) | |
1156 (cis . | |
1157 ((offset . (0.0 . 0.0)) | |
1158 (stencil . ,oboe-lh-cis-key-stencil) | |
1159 (text? . ("C" . 1)) | |
1160 (complexity . trill))) | |
1161 (gis . | |
1162 ((offset . (-0.85 . 0.2)) | |
1163 (stencil . ,oboe-lh-gis-key-stencil) | |
1164 (text? . ("G" . 1)) | |
1165 (complexity . trill))) | |
1166 (ees . | |
1167 ((offset . (2.05 . -3.65)) | |
1168 (stencil . ,oboe-lh-ees-key-stencil) | |
1169 (text? . ("E" . 0)) | |
1170 (complexity . trill))) | |
1171 (low-b . | |
1172 ((offset . (3.6 . 0.5)) | |
1173 (stencil . ,oboe-lh-low-b-key-stencil) | |
1174 (text? . ("b" . #f)) | |
1175 (complexity . trill))) | |
1176 (bes . | |
1177 ((offset . (2.25 . -4.15)) | |
1178 (stencil . ,oboe-lh-bes-key-stencil) | |
1179 (text? . ("B" . 0)) | |
1180 (complexity . trill))) | |
1181 (f . | |
1182 ((offset . (2.15 . -3.85)) | |
1183 (stencil . ,oboe-lh-f-key-stencil) | |
1184 (text? . ("F" . #f)) | |
1185 (complexity . trill))))) | |
1186 (right-hand . | |
1187 ((a . | |
1188 ((offset . (1.5 . 1.2)) | |
1189 (stencil . ,oboe-rh-a-key-stencil) | |
1190 (text? . ("A" . #f)) | |
1191 (complexity . trill))) | |
1192 (gis . | |
1193 ((offset . (0.0 . 0.0)) | |
1194 (stencil . ,oboe-rh-gis-key-stencil) | |
1195 (text? . ("G" . 1)) | |
1196 (complexity . trill))) | |
1197 (d . | |
1198 ((offset . (0.0 . 0.0)) | |
1199 (stencil . ,oboe-rh-d-key-stencil) | |
1200 (text? . ("D" . #f)) | |
1201 (complexity . trill))) | |
1202 (f . | |
1203 ((offset . (0.0 . 0.0)) | |
1204 (stencil . ,oboe-rh-f-key-stencil) | |
1205 (text? . ("F" . #f)) | |
1206 (complexity . trill))) | |
1207 (banana . | |
1208 ((offset . (0.0 . 0.0)) | |
1209 (stencil . ,oboe-rh-banana-key-stencil) | |
1210 (text? . ("ban" . #f)) | |
1211 (complexity . trill))) | |
1212 (c . | |
1213 ((offset . (0.0 . 0.0)) | |
1214 (stencil . ,oboe-rh-c-key-stencil) | |
1215 (text? . ("C" . #f)) | |
1216 (complexity . trill))) | |
1217 (cis . | |
1218 ((offset . (3.8 . -0.6)) | |
1219 (stencil . ,oboe-rh-cis-key-stencil) | |
1220 (text? . ("C" . 1)) | |
1221 (complexity . trill))) | |
1222 (ees . | |
1223 ((offset . (0.0 . -1.8)) | |
1224 (stencil . ,oboe-rh-ees-key-stencil) | |
1225 (text? . ("E" . 0)) | |
1226 (complexity . trill))))))) | |
1227 (graphical-commands . | |
1228 ((stencil-alist . | |
1229 ((stencils . | |
1230 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1231 ((stencils . | |
1232 ,(make-central-column-hole-addresses | |
1233 '(one two three four five six h))) | |
1234 (xy-scale-function . (,return-x . ,return-x)) | |
1235 (textual? . #f) | |
1236 (offset . (0.0 . 0.0))) | |
1237 ((stencils . | |
1238 ((left-hand . I) (left-hand . III))) | |
1239 (xy-scale-function . (,return-1 . ,return-1)) | |
1240 (textual? . #f) | |
1241 (offset . (-2.5 . 6.5))) | |
1242 ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0)) | |
1243 ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0)) | |
1244 ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0)) | |
1245 ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0)) | |
1246 ((stencils . | |
1247 ,(make-left-hand-key-addresses '(gis bes low-b ees f))) | |
1248 (xy-scale-function . (,return-1 . ,return-1)) | |
1249 (textual? . #f) | |
1250 (offset . (0.0 . 3.9))) | |
1251 ((stencils . | |
1252 ,(make-right-hand-key-addresses '(a gis))) | |
1253 (xy-scale-function . (,return-1 . ,return-1)) | |
1254 (textual? . #f) | |
1255 (offset . (-3.5 . 3.5))) | |
1256 ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5)) | |
1257 ,(simple-stencil-alist '(right-hand . f) '(-1.0 . 1.5)) | |
1258 ,(simple-stencil-alist '(right-hand . banana) '(1.7 . 1.0)) | |
1259 ((stencils . ,(make-right-hand-key-addresses '(c cis ees))) | |
1260 (xy-scale-function . (,return-1 . ,return-1)) | |
1261 (textual? . #f) | |
1262 (offset . (-3.4 . 0.3))))) | |
1263 (xy-scale-function . (,return-x . ,return-x)) | |
1264 (textual? . #f) | |
1265 (offset . (0.0 . 0.0)))) | |
1266 (draw-instructions . | |
1267 ((,apply-group-draw-rule-series | |
1268 (((right-hand . a) (right-hand . gis)) | |
1269 ,(make-left-hand-key-addresses '(gis bes low-b ees)) | |
1270 ,(make-right-hand-key-addresses '(cis c ees)))) | |
1271 (,rich-group-draw-rule | |
1272 ((left-hand . III)) | |
1273 ((left-hand . I))) ; III | |
1274 (,rich-group-draw-rule | |
1275 ((left-hand . f)) | |
1276 ,(make-left-hand-key-addresses '(gis bes low-b ees))) ; f | |
1277 (,group-automate-rule | |
1278 ,(make-central-column-hole-addresses '(one two three four five six))) | |
1279 (,group-automate-rule ((hidden . midline))))) | |
1280 (extra-offset-instructions . | |
1281 ((,rich-group-extra-offset-rule | |
1282 ((central-column . h)) ((central-column . six)) (0.0 . 0.8)) | |
1283 (,uniform-extra-offset-rule (0.0 . 0.0)) | |
1284 )))) | |
1285 (text-commands . | |
1286 ((stencil-alist . | |
1287 ((stencils . | |
1288 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1289 ((stencils . | |
1290 ,(make-central-column-hole-addresses | |
1291 '(one two three four five six h))) | |
1292 (xy-scale-function . (,return-x . ,return-x)) | |
1293 (textual? . #f) | |
1294 (offset . (0.0 . 0.0))) | |
1295 ((stencils . ,(make-left-hand-key-addresses '(III I))) | |
1296 (textual? . ,lh-woodwind-text-stencil) | |
1297 (offset . (-2.8 . 7.0))) | |
1298 ((stencils . ,(make-left-hand-key-addresses '(II))) | |
1299 (textual? . ,lh-woodwind-text-stencil) | |
1300 (offset . (2.2 . 7.0))) | |
1301 ((stencils . | |
1302 ,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f))) | |
1303 (textual? . ,lh-woodwind-text-stencil) | |
1304 (offset . (1.5 . 3.75))) | |
1305 ((stencils . | |
1306 ,(make-right-hand-key-addresses '(a gis d f banana c cis ees))) | |
1307 (textual? . ,rh-woodwind-text-stencil) | |
1308 (offset . (-1.25 . 0.0))))) | |
1309 (xy-scale-function . (,return-x . ,return-x)) | |
1310 (textual? . #f) | |
1311 (offset . (0.0 . 0.0)))) | |
1312 (draw-instructions . | |
1313 ((,apply-group-draw-rule-series | |
1314 (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f)) | |
1315 ,(make-left-hand-key-addresses '(III I)) | |
1316 ,(make-right-hand-key-addresses '(a gis d f banana c cis ees)))) | |
1317 (,group-automate-rule | |
1318 ,(make-central-column-hole-addresses '(one two three four five six))) | |
1319 (,group-automate-rule ((hidden . midline))))) | |
1320 (extra-offset-instructions . | |
1321 ((,rich-group-extra-offset-rule | |
1322 ((central-column . h)) | |
1323 ((central-column . six)) | |
1324 (0.0 . 0.8)) | |
1325 (,uniform-extra-offset-rule (0.0 . 0.0)) | |
1326 )))))))) | |
1327 | |
1328 ;;; Clarinet family stencils | |
1329 | |
1330 (define clarinet-lh-thumb-key-stencil column-circle-stencil) | |
1331 | |
1332 (define clarinet-lh-R-key-stencil | |
1333 (let* ((halfbase (cos (/ PI 10))) | |
1334 (height (* | |
1335 halfbase | |
1336 (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10)))))) | |
1337 (standard-mcs-stencil | |
1338 `( | |
1339 (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0) | |
1340 (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height) | |
1341 (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0)) | |
1342 1.0 | |
1343 1.0))) | |
1344 | |
1345 (define (clarinet-lh-a-key-stencil radius thick fill layout props) | |
1346 (let* ((width 0.4) (height 0.75) (linelen 0.45)) | |
1347 (ly:stencil-add | |
1348 ((standard-e-stencil width height) radius thick fill layout props) | |
1349 (ly:stencil-translate | |
1350 (make-line-stencil thick 0 0 0 (* linelen radius)) | |
1351 (cons 0 (* height radius)))))) | |
1352 | |
1353 (define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0)) | |
1354 | |
1355 (define clarinet-lh-ees-key-stencil little-elliptical-key-stencil) | |
1356 | |
1357 (define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil) | |
1358 | |
1359 (define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil) | |
1360 | |
1361 (define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil) | |
1362 | |
1363 (define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil) | |
1364 | |
1365 (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25)) | |
1366 | |
1367 (define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil) | |
1368 | |
1369 (define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil) | |
1370 | |
1371 (define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil) | |
1372 | |
1373 (define clarinet-rh-b-key-stencil little-elliptical-key-stencil) | |
1374 | |
1375 ; cl low-rh values | |
1376 (define CL-RH-HAIR 0.09) | |
1377 (define CL-RH-H-STRETCH 2.7) | |
1378 (define CL-RH-V-STRETCH 0.9) | |
1379 | |
1380 ; TODO | |
1381 ; there is some unnecessary information duplication here. | |
1382 ; need a way to control all of the below stencils so that if one | |
1383 ; changes, all change... | |
1384 | |
1385 (define clarinet-rh-fis-key-stencil | |
1386 (standard-mcs-stencil | |
1387 `(,(bezier-head-for-stencil | |
1388 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) | |
1389 0.5) | |
1390 ,(bezier-head-for-stencil | |
1391 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) | |
1392 0.5) | |
1393 (1.0 1.0 0.0 1.0 0.0 0.0)) | |
1394 CL-RH-H-STRETCH | |
1395 CL-RH-V-STRETCH)) | |
1396 | |
1397 (define clarinet-rh-e-key-stencil | |
1398 (standard-mcs-stencil | |
1399 '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0)) | |
1400 CL-RH-H-STRETCH | |
1401 CL-RH-V-STRETCH)) | |
1402 | |
1403 (define clarinet-rh-ees-key-stencil | |
1404 (standard-mcs-stencil | |
1405 `(,(bezier-head-for-stencil | |
1406 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) | |
1407 0.5) | |
1408 ,(bezier-head-for-stencil | |
1409 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) | |
1410 0.5) | |
1411 ,(bezier-head-for-stencil | |
1412 `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5)) | |
1413 0.5) | |
1414 ,(bezier-head-for-stencil | |
1415 `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75)) | |
1416 0.5)) | |
1417 CL-RH-H-STRETCH | |
1418 CL-RH-V-STRETCH)) | |
1419 | |
1420 (define clarinet-rh-gis-key-stencil clarinet-rh-e-key-stencil) | |
1421 | |
1422 (define clarinet-rh-f-key-stencil | |
1423 (standard-mcs-stencil | |
1424 `(,(bezier-head-for-stencil | |
1425 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) | |
1426 0.5) | |
1427 ,(bezier-head-for-stencil | |
1428 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) | |
1429 0.5) | |
1430 (1.0 1.0 0.0 1.0 0.0 0.0)) | |
1431 CL-RH-H-STRETCH | |
1432 (- CL-RH-V-STRETCH))) | |
1433 | |
1434 (define clarinet-change-points | |
1435 ((make-named-spreadsheet '(clarinet bass-clarinet)) | |
1436 `((bottom-group-key-names . | |
1437 (() | |
1438 ((f . | |
1439 ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR)))) | |
1440 (stencil . ,clarinet-rh-f-key-stencil) | |
1441 (text? . ("F" . #f)) | |
1442 (complexity . trill)))))) | |
1443 (bottom-group-graphical-stencil . | |
1444 (,(make-right-hand-key-addresses '(fis e ees gis)) | |
1445 ,(make-right-hand-key-addresses '(fis e ees gis f)))) | |
1446 (bottom-group-graphical-draw-instruction . | |
1447 (,(make-right-hand-key-addresses '(fis e ees gis)) | |
1448 ,(make-right-hand-key-addresses '(fis e ees gis f)))) | |
1449 (bottom-group-text-stencil . | |
1450 (,(make-right-hand-key-addresses '(b fis e ees gis)) | |
1451 ,(make-right-hand-key-addresses '(b fis e ees gis f)))) | |
1452 (bottom-group-text-draw-instruction . | |
1453 (,(make-right-hand-key-addresses '(b fis e ees gis)) | |
1454 ,(make-right-hand-key-addresses '(b fis e ees gis f))))))) | |
1455 | |
1456 (define (generate-clarinet-family-entry clarinet-name) | |
1457 (let* | |
1458 ((change-points | |
1459 (get-named-spreadsheet-column clarinet-name clarinet-change-points))) | |
1460 `(,clarinet-name . | |
1461 ((keys . | |
1462 ((hidden . | |
1463 ((midline . | |
1464 ((offset . (0.0 . 0.0)) | |
1465 (stencil . ,midline-stencil) | |
1466 (text? . #f) | |
1467 (complexity . basic))))) | |
1468 (central-column . | |
1469 ((one . | |
1470 ((offset . (0.0 . 1.0)) | |
1471 (stencil . ,column-circle-stencil) | |
1472 (text? . #f) | |
1473 (complexity . covered))) | |
1474 (two . | |
1475 ((offset . (0.0 . 2.0)) | |
1476 (stencil . ,column-circle-stencil) | |
1477 (text? . #f) | |
1478 (complexity . covered))) | |
1479 (three . | |
1480 ((offset . (0.0 . 3.0)) | |
1481 (stencil . ,column-circle-stencil) | |
1482 (text? . #f) | |
1483 (complexity . covered))) | |
1484 (four . | |
1485 ((offset . (0.0 . 4.5)) | |
1486 (stencil . ,column-circle-stencil) | |
1487 (text? . #f) | |
1488 (complexity . covered))) | |
1489 (five . | |
1490 ((offset . (0.0 . 5.5)) | |
1491 (stencil . ,column-circle-stencil) | |
1492 (text? . #f) | |
1493 (complexity . covered))) | |
1494 (six . | |
1495 ((offset . (0.0 . 6.5)) | |
1496 (stencil . ,column-circle-stencil) | |
1497 (text? . #f) | |
1498 (complexity . covered))) | |
1499 (h . | |
1500 ((offset . (0.0 . 6.25)) | |
1501 (stencil . ,(variable-column-circle-stencil 0.4)) | |
1502 (text? . #f) | |
1503 (complexity . covered))))) | |
1504 (left-hand . | |
1505 ((thumb . | |
1506 ((offset . (0.0 . 0.0)) | |
1507 (stencil . ,clarinet-lh-thumb-key-stencil) | |
1508 (text? . #f) | |
1509 (complexity . trill))) | |
1510 (R . | |
1511 ((offset . (1.0 . 1.0)) | |
1512 (stencil . ,clarinet-lh-R-key-stencil) | |
1513 (text? . #f) | |
1514 (complexity . trill))) | |
1515 (a . | |
1516 ((offset . (0.0 . 0.0)) | |
1517 (stencil . ,clarinet-lh-a-key-stencil) | |
1518 (text? . ("A" . #f)) | |
1519 (complexity . trill))) | |
1520 (gis . | |
1521 ((offset . (0.8 . 1.0)) | |
1522 (stencil . ,clarinet-lh-gis-key-stencil) | |
1523 (text? . ("G" . 1)) | |
1524 (complexity . trill))) | |
1525 (ees . | |
1526 ((offset . (0.0 . 0.0)) | |
1527 (stencil . ,clarinet-lh-ees-key-stencil) | |
1528 (text? . ("E" . 0)) | |
1529 (complexity . trill))) | |
1530 (cis . | |
1531 ((offset . (-0.85 . 0.2)) | |
1532 (stencil . ,clarinet-lh-cis-key-stencil) | |
1533 (text? . ("C" . 1)) | |
1534 (complexity . trill))) | |
1535 (f . | |
1536 ((offset . (3.6 . 0.5)) | |
1537 (stencil . ,clarinet-lh-f-key-stencil) | |
1538 (text? . ("F" . #f)) | |
1539 (complexity . trill))) | |
1540 (e . | |
1541 ((offset . (2.05 . -3.65)) | |
1542 (stencil . ,clarinet-lh-e-key-stencil) | |
1543 (text? . ("E" . #f)) | |
1544 (complexity . trill))) | |
1545 (fis . | |
1546 ((offset . (2.25 . -4.15)) | |
1547 (stencil . ,clarinet-lh-fis-key-stencil) | |
1548 (text? . ("F" . 1)) | |
1549 (complexity . trill))))) | |
1550 (right-hand . | |
1551 ,(append | |
1552 `((one . | |
1553 ((offset . (0.0 . 0.75)) | |
1554 (stencil . ,clarinet-rh-one-key-stencil) | |
1555 (text? . "1") | |
1556 (complexity . trill))) | |
1557 (two . | |
1558 ((offset . (0.0 . 0.25)) | |
1559 (stencil . ,clarinet-rh-two-key-stencil) | |
1560 (text? . "2") | |
1561 (complexity . trill))) | |
1562 (three . | |
1563 ((offset . (0.0 . -0.25)) | |
1564 (stencil . ,clarinet-rh-three-key-stencil) | |
1565 (text? . "3") | |
1566 (complexity . trill))) | |
1567 (four . | |
1568 ((offset . (0.0 . -0.75)) | |
1569 (stencil . ,clarinet-rh-four-key-stencil) | |
1570 (text? . "4") | |
1571 (complexity . trill))) | |
1572 (b . | |
1573 ((offset . (0.0 . 0.0)) | |
1574 (stencil . ,clarinet-rh-b-key-stencil) | |
1575 (text? . ("B" . #f)) | |
1576 (complexity . trill))) | |
1577 (fis . | |
1578 ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR)))) | |
1579 (stencil . ,clarinet-rh-fis-key-stencil) | |
1580 (text? . ("F" . 1)) | |
1581 (complexity . trill))) | |
1582 (e . | |
1583 ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* 3 (+ 0.75 CL-RH-HAIR)))) | |
1584 (stencil . ,clarinet-rh-e-key-stencil) | |
1585 (text? . ("E" . #f)) | |
1586 (complexity . trill))) | |
1587 (ees . | |
1588 ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR)))) | |
1589 (stencil . ,clarinet-rh-ees-key-stencil) | |
1590 (text? . ("E" . 0)) | |
1591 (complexity . trill))) | |
1592 (gis . | |
1593 ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* 1 (+ 0.75 CL-RH-HAIR)))) | |
1594 (stencil . ,clarinet-rh-gis-key-stencil) | |
1595 (text? . ("G" . 1)) | |
1596 (complexity . trill)))) | |
1597 (assoc-get 'bottom-group-key-names change-points))))) | |
1598 (graphical-commands . | |
1599 ((stencil-alist . | |
1600 ((stencils . | |
1601 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1602 ((stencils . | |
1603 ,(make-central-column-hole-addresses | |
1604 '(one two three four five six h))) | |
1605 (xy-scale-function . (,return-x . ,return-x)) | |
1606 (textual? . #f) | |
1607 (offset . (0.0 . 0.0))) | |
1608 ((stencils . | |
1609 ((left-hand . thumb) (left-hand . R))) | |
1610 (xy-scale-function . (,return-x . ,return-x)) | |
1611 (textual? . #f) | |
1612 (offset . (-2.5 . 6.5))) | |
1613 ((stencils . | |
1614 ((left-hand . a) (left-hand . gis))) | |
1615 (xy-scale-function . (,return-1 . ,return-1)) | |
1616 (textual? . #f) | |
1617 (offset . (0.0 . 7.5))) | |
1618 ,(simple-stencil-alist '(left-hand . ees) '(1.0 . 5.0)) | |
1619 ((stencils . ,(make-left-hand-key-addresses '(cis f e fis))) | |
1620 (xy-scale-function . (,return-1 . ,return-1)) | |
1621 (textual? . #f) | |
1622 (offset . (0.0 . 3.9))) | |
1623 ((stencils . ,(make-right-hand-key-addresses '(one two three four))) | |
1624 (xy-scale-function . (,return-1 . ,return-1)) | |
1625 (textual? . #f) | |
1626 (offset . (-1.25 . 3.75))) | |
1627 ,(simple-stencil-alist '(right-hand . b) '(-1.0 . 1.5)) | |
1628 ((stencils . | |
1629 ,(assoc-get 'bottom-group-graphical-stencil change-points)) | |
1630 (xy-scale-function . (,return-1 . ,return-1)) | |
1631 (textual? . #f) | |
1632 (offset . (-4.0 . -0.75))))) | |
1633 (xy-scale-function . (,return-x . ,return-x)) | |
1634 (textual? . #f) | |
1635 (offset . (0.0 . 0.0)))) | |
1636 (draw-instructions . | |
1637 ((,apply-group-draw-rule-series | |
1638 (((left-hand . a) (left-hand . gis)) | |
1639 ,(make-right-hand-key-addresses '(one two three four)) | |
1640 ,(make-left-hand-key-addresses '(cis f e fis)) | |
1641 ,(assoc-get 'bottom-group-graphical-draw-instruction change-points))) | |
1642 (,rich-group-draw-rule | |
1643 ((left-hand . R)) | |
1644 ((left-hand . thumb))) ; thumb | |
1645 (,group-automate-rule | |
1646 ,(make-central-column-hole-addresses '(one two three four five six))) | |
1647 (,group-automate-rule ((hidden . midline))))) | |
1648 (extra-offset-instructions . | |
1649 ((,rich-group-extra-offset-rule | |
1650 ((central-column . h)) | |
1651 ((central-column . six) (left-hand . a) (left-hand . gis)) | |
1652 (0.0 . 0.8)) | |
1653 (,uniform-extra-offset-rule (0.0 . 0.0)) | |
1654 )))) | |
1655 (text-commands . | |
1656 ((stencil-alist . | |
1657 ((stencils . | |
1658 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1659 ((stencils . | |
1660 ,(make-central-column-hole-addresses | |
1661 '(one two three four five six))) | |
1662 (xy-scale-function . (,return-x . ,return-x)) | |
1663 (textual? . #f) | |
1664 (offset . (0.0 . 0.0))) | |
1665 ((stencils . | |
1666 ((left-hand . thumb) (left-hand . R))) | |
1667 (xy-scale-function . (,return-x . ,return-x)) | |
1668 (textual? . #f) | |
1669 (offset . (-2.5 . 6.5))) | |
1670 ((stencils . | |
1671 ,(make-left-hand-key-addresses '(a gis ees cis f e fis))) | |
1672 (textual? . ,lh-woodwind-text-stencil) | |
1673 (offset . (1.5 . 3.75))) | |
1674 ((stencils . | |
1675 ,(make-right-hand-key-addresses '(one two three four))) | |
1676 (textual? . ,number-column-stencil) | |
1677 (offset . (-1.25 . 3.75))) | |
1678 ((stencils . ,(assoc-get 'bottom-group-text-stencil change-points)) | |
1679 (textual? . ,rh-woodwind-text-stencil) | |
1680 (offset . (-1.25 . 0.0))))) | |
1681 (xy-scale-function . (,return-x . ,return-x)) | |
1682 (textual? . #f) | |
1683 (offset . (0.0 . 0.0)))) | |
1684 (draw-instructions . | |
1685 ((,apply-group-draw-rule-series | |
1686 (,(make-left-hand-key-addresses '(a gis ees cis f e fis)) | |
1687 ,(make-right-hand-key-addresses '(one two three four)) | |
1688 ,(assoc-get 'bottom-group-text-draw-instruction change-points))) | |
1689 (,group-automate-rule | |
1690 ,(make-central-column-hole-addresses '(one two three four five six))) | |
1691 (,group-automate-rule ((hidden . midline))))) | |
1692 (extra-offset-instructions . | |
1693 ((,rich-group-extra-offset-rule | |
1694 ((central-column . h)) | |
1695 ((central-column . six) (left-hand . a) (left-hand . gis)) | |
1696 (0.0 . 0.8)) | |
1697 (,uniform-extra-offset-rule (0.0 . 0.0)) | |
1698 )))))))) | |
1699 | |
1700 ;;; Saxophone family stencils | |
1701 | |
1702 (define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 0.9 1.8)) | |
1703 | |
1704 (define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 0.9 1.8)) | |
1705 | |
1706 (define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 0.9 1.8)) | |
1707 | |
1708 (define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.5 0.5)) | |
1709 | |
1710 (define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5)) | |
1711 | |
1712 (define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75)) | |
1713 | |
1714 (define saxophone-lh-gis-key-stencil | |
1715 (standard-mcs-stencil | |
1716 '((0.0 0.4) | |
1717 (0.0 0.8 3.0 0.8 3.0 0.4) | |
1718 (3.0 0.0) | |
1719 (3.0 -0.4 0.0 -0.4 0.0 0.0)) | |
1720 0.8 | |
1721 0.8)) | |
1722 | |
1723 (define (saxophone-lh-b-cis-key-stencil flip?) | |
1724 (standard-mcs-stencil | |
1725 '((0.0 1.0) | |
1726 (0.4 1.0 0.8 0.9 1.35 0.8) | |
1727 (1.35 0.0) | |
1728 (0.0 0.0)) | |
1729 (* (if flip? -1 1) 0.8) | |
1730 0.8)) | |
1731 | |
1732 (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t)) | |
1733 | |
1734 (define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f)) | |
1735 | |
1736 (define saxophone-lh-low-bes-key-stencil | |
1737 (standard-mcs-stencil | |
1738 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) | |
1739 0.8 | |
1740 0.8)) | |
1741 | |
1742 (define (saxophone-rh-side-key-stencil width height) | |
1743 (standard-mcs-stencil | |
1744 `((0.0 ,height) | |
1745 (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15)) | |
1746 (,(- width 0.15) ,(+ height 0.15)) | |
1747 (,(- width 0.1) | |
1748 ,(+ height 0.1) | |
1749 ,(- width 0.05) | |
1750 ,(+ height 0.05) | |
1751 ,width | |
1752 ,height) | |
1753 (,width 0.0) | |
1754 (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15) | |
1755 (0.15 -0.15) | |
1756 (0.1 -0.1 0.05 -0.05 0.0 0.0)) | |
1757 1.0 | |
1758 1.0)) | |
1759 | |
1760 (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.6 0.8)) | |
1761 | |
1762 (define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.6 0.4)) | |
1763 | |
1764 (define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.6 0.3)) | |
1765 | |
1766 (define saxophone-rh-high-fis-key-stencil | |
1767 (standard-mcs-stencil | |
1768 (append | |
1769 '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0)) | |
1770 (map | |
1771 (lambda | |
1772 (l) | |
1773 (flatten-list | |
1774 (map | |
1775 (lambda | |
1776 (x) | |
1777 (interval-rotate x (atan (* -1 (/ PI 6))))) | |
1778 l))) | |
1779 '(((0.6 . -1.0)) | |
1780 ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0)) | |
1781 ((0.0 . 0.0))))) | |
1782 0.75 | |
1783 0.75)) | |
1784 | |
1785 (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5)) | |
1786 | |
1787 (define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5)) | |
1788 | |
1789 (define saxophone-rh-low-c-key-stencil | |
1790 (standard-mcs-stencil | |
1791 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) | |
1792 0.8 | |
1793 0.8)) | |
1794 | |
1795 (define saxophone-change-points | |
1796 ((make-named-spreadsheet '(saxophone)) '())) | |
1797 | |
1798 (define (generate-saxophone-family-entry saxophone-name) | |
1799 (let* | |
1800 ((change-points | |
1801 (get-named-spreadsheet-column saxophone-name saxophone-change-points))) | |
1802 `(,saxophone-name . | |
1803 ((keys . | |
1804 ((hidden . | |
1805 ((midline . | |
1806 ((offset . (0.0 . 0.0)) | |
1807 (stencil . ,midline-stencil) | |
1808 (text? . #f) | |
1809 (complexity . basic))))) | |
1810 (central-column . | |
1811 ((one . | |
1812 ((offset . (0.0 . 1.0)) | |
1813 (stencil . ,column-circle-stencil) | |
1814 (text? . #f) | |
1815 (complexity . trill))) | |
1816 (two . | |
1817 ((offset . (0.0 . 2.0)) | |
1818 (stencil . ,column-circle-stencil) | |
1819 (text? . #f) | |
1820 (complexity . trill))) | |
1821 (three . | |
1822 ((offset . (0.0 . 3.0)) | |
1823 (stencil . ,column-circle-stencil) | |
1824 (text? . #f) | |
1825 (complexity . trill))) | |
1826 (four . | |
1827 ((offset . (0.0 . 4.5)) | |
1828 (stencil . ,column-circle-stencil) | |
1829 (text? . #f) | |
1830 (complexity . trill))) | |
1831 (five . | |
1832 ((offset . (0.0 . 5.5)) | |
1833 (stencil . ,column-circle-stencil) | |
1834 (text? . #f) | |
1835 (complexity . trill))) | |
1836 (six . | |
1837 ((offset . (0.0 . 6.5)) | |
1838 (stencil . ,column-circle-stencil) | |
1839 (text? . #f) | |
1840 (complexity . trill))))) | |
1841 (left-hand . | |
1842 ((T . | |
1843 ((offset . (0.0 . 0.0)) | |
1844 (stencil . ,saxophone-lh-T-key-stencil) | |
1845 (text? . ("T" . #f)) | |
1846 (complexity . trill))) | |
1847 (ees . | |
1848 ((offset . (0.5 . 1.6)) | |
1849 (stencil . ,saxophone-lh-ees-key-stencil) | |
1850 (text? . ("E" . 0)) | |
1851 (complexity . trill))) | |
1852 (d . | |
1853 ((offset . (1.5 . 0.5)) | |
1854 (stencil . ,saxophone-lh-d-key-stencil) | |
1855 (text? . ("D" . #f)) | |
1856 (complexity . trill))) | |
1857 (f . | |
1858 ((offset . (0.0 . 0.0)) | |
1859 (stencil . ,saxophone-lh-f-key-stencil) | |
1860 (text? . ("F" . #f)) | |
1861 (complexity . trill))) | |
1862 (front-f . | |
1863 ((offset . (0.0 . 0.0)) | |
1864 (stencil . ,saxophone-lh-front-f-key-stencil) | |
1865 (text? . ("f" . #f)) | |
1866 (complexity . trill))) | |
1867 (bes . | |
1868 ((offset . (0.0 . 0.0)) | |
1869 (stencil . ,saxophone-lh-bes-key-stencil) | |
1870 (text? . ("B" . 0)) | |
1871 (complexity . trill))) | |
1872 (gis . | |
1873 ((offset . (0.0 . 1.1)) | |
1874 (stencil . ,saxophone-lh-gis-key-stencil) | |
1875 (text? . ("G" . 1)) | |
1876 (complexity . trill))) | |
1877 (cis . | |
1878 ((offset . (2.4 . 0.0)) | |
1879 (stencil . ,saxophone-lh-cis-key-stencil) | |
1880 (text? . ("C" . 1)) | |
1881 (complexity . trill))) | |
1882 (b . | |
1883 ((offset . (0.0 . 0.0)) | |
1884 (stencil . ,saxophone-lh-b-key-stencil) | |
1885 (text? . ("B" . #f)) | |
1886 (complexity . trill))) | |
1887 (low-bes . | |
1888 ((offset . (0.0 . -0.2)) | |
1889 (stencil . ,saxophone-lh-low-bes-key-stencil) | |
1890 (text? . ("b" . 0)) | |
1891 (complexity . trill))))) | |
1892 (right-hand . | |
1893 ((e . | |
1894 ((offset . (0.0 . 1.7)) | |
1895 (stencil . ,saxophone-rh-e-key-stencil) | |
1896 (text? . ("E" . #f)) | |
1897 (complexity . trill))) | |
1898 (c . | |
1899 ((offset . (0.0 . 0.8)) | |
1900 (stencil . ,saxophone-rh-c-key-stencil) | |
1901 (text? . ("C" . #f)) | |
1902 (complexity . trill))) | |
1903 (bes . | |
1904 ((offset . (0.0 . 0.0)) | |
1905 (stencil . ,saxophone-rh-bes-key-stencil) | |
1906 (text? . ("B" . 0)) | |
1907 (complexity . trill))) | |
1908 (high-fis . | |
1909 ((offset . (0.0 . 0.0)) | |
1910 (stencil . ,saxophone-rh-high-fis-key-stencil) | |
1911 (text? . ("hF" . 1)) | |
1912 (complexity . trill))) | |
1913 (fis . | |
1914 ((offset . (0.0 . 0.0)) | |
1915 (stencil . ,saxophone-rh-fis-key-stencil) | |
1916 (text? . ("F" . 1)) | |
1917 (complexity . trill))) | |
1918 (ees . | |
1919 ((offset . (0.0 . 0.7)) | |
1920 (stencil . ,saxophone-rh-ees-key-stencil) | |
1921 (text? . ("E" . 0)) | |
1922 (complexity . trill))) | |
1923 (low-c . | |
1924 ((offset . (-1.2 . -0.1)) | |
1925 (stencil . ,saxophone-rh-low-c-key-stencil) | |
1926 (text? . ("c" . #f)) | |
1927 (complexity . trill))))))) | |
1928 (graphical-commands . | |
1929 ((stencil-alist . | |
1930 ((stencils . | |
1931 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1932 ((stencils . | |
1933 ,(make-central-column-hole-addresses | |
1934 '(one two three four five six))) | |
1935 (xy-scale-function . (,return-x . ,return-x)) | |
1936 (textual? . #f) | |
1937 (offset . (0.0 . 0.0))) | |
1938 ((stencils . | |
1939 ((left-hand . ees) (left-hand . d) (left-hand . f))) | |
1940 (xy-scale-function . (,return-1 . ,return-1)) | |
1941 (textual? . #f) | |
1942 (offset . (1.5 . 6.8))) | |
1943 ,(simple-stencil-alist '(left-hand . front-f) '(0.0 . 7.6)) | |
1944 ,(simple-stencil-alist '(left-hand . T) '(-2.2 . 6.5)) | |
1945 ,(simple-stencil-alist '(left-hand . bes) '(0.0 . 6.2)) | |
1946 ((stencils . | |
1947 ,(make-left-hand-key-addresses '(gis cis b low-bes))) | |
1948 (xy-scale-function . (,return-1 . ,return-1)) | |
1949 (textual? . #f) | |
1950 (offset . (1.2 . 3.5))) | |
1951 ((stencils . | |
1952 ,(make-right-hand-key-addresses '(e c bes))) | |
1953 (xy-scale-function . (,return-1 . ,return-1)) | |
1954 (textual? . #f) | |
1955 (offset . (-2.0 . 3.2))) | |
1956 ,(simple-stencil-alist '(right-hand . high-fis) '(-1.8 . 2.5)) | |
1957 ,(simple-stencil-alist '(right-hand . fis) '(-1.5 . 1.5)) | |
1958 ((stencils . ,(make-right-hand-key-addresses '(ees low-c))) | |
1959 (xy-scale-function . (,return-1 . ,return-1)) | |
1960 (textual? . #f) | |
1961 (offset . (-2.0 . 0.3))))) | |
1962 (xy-scale-function . (,return-x . ,return-x)) | |
1963 (textual? . #f) | |
1964 (offset . (0.0 . 0.0)))) | |
1965 (draw-instructions . | |
1966 ((,apply-group-draw-rule-series | |
1967 (,(make-left-hand-key-addresses '(ees d f)) | |
1968 ,(make-left-hand-key-addresses '(gis cis b low-bes)) | |
1969 ,(make-right-hand-key-addresses '(e c bes)) | |
1970 ,(make-right-hand-key-addresses '(ees low-c)))) | |
1971 (,group-automate-rule | |
1972 ,(make-central-column-hole-addresses '(one two three four five six))) | |
1973 (,group-automate-rule ((hidden . midline))))) | |
1974 (extra-offset-instructions . | |
1975 ((,rich-group-extra-offset-rule | |
1976 ((left-hand . bes)) | |
1977 ((central-column . six) | |
1978 (left-hand . front-f) | |
1979 (left-hand . T) | |
1980 (left-hand . ees) | |
1981 (left-hand . d) | |
1982 (left-hand . f)) | |
1983 (0.0 . 1.0)) | |
1984 (,uniform-extra-offset-rule (0.0 . 0.0)) | |
1985 )))) | |
1986 (text-commands . | |
1987 ((stencil-alist . | |
1988 ((stencils . | |
1989 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
1990 ((stencils . | |
1991 ,(make-central-column-hole-addresses | |
1992 '(one two three four five six))) | |
1993 (xy-scale-function . (,return-x . ,return-x)) | |
1994 (textual? . #f) | |
1995 (offset . (0.0 . 0.0))) | |
1996 ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0)) | |
1997 ((stencils . | |
1998 ,(make-left-hand-key-addresses | |
1999 '(ees d f front-f bes gis cis b low-bes))) | |
2000 (textual? . ,lh-woodwind-text-stencil) | |
2001 (offset . (1.5 . 3.75))) | |
2002 ((stencils . | |
2003 ,(make-right-hand-key-addresses '(e c bes high-fis fis ees low-c))) | |
2004 (textual? . ,rh-woodwind-text-stencil) | |
2005 (offset . (-1.25 . 0.0))))) | |
2006 (xy-scale-function . (,return-x . ,return-x)) | |
2007 (textual? . #f) | |
2008 (offset . (0.0 . 0.0)))) | |
2009 (draw-instructions . | |
2010 ((,apply-group-draw-rule-series | |
2011 (,(make-left-hand-key-addresses | |
2012 '(ees d f front-f bes gis cis b low-bes)) | |
2013 ,(make-right-hand-key-addresses | |
2014 '(e c bes high-fis fis ees low-c)))) | |
2015 (,group-automate-rule | |
2016 ,(make-central-column-hole-addresses '(one two three four five six))) | |
2017 (,group-automate-rule ((hidden . midline))))) | |
2018 (extra-offset-instructions . | |
2019 ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) | |
2020 | |
2021 ;;; Bassoon family stencils | |
2022 | |
2023 (define (bassoon-bend-info-maker height gap cut) | |
2024 (let* ( | |
2025 (first-bezier | |
2026 (flatten-list | |
2027 (car | |
2028 (split-bezier | |
2029 `((0.0 . ,(+ height gap)) | |
2030 (0.0 . ,(+ height (+ gap 1.0))) | |
2031 (1.0 . ,(+ height (+ gap 2.0))) | |
2032 (2.0 . ,(+ height (+ gap 2.0)))) | |
2033 cut)))) | |
2034 (second-bezier | |
2035 (flatten-list | |
2036 (reverse | |
2037 (car | |
2038 (split-bezier | |
2039 `((1.0 . ,height) | |
2040 (1.0 . ,(+ 0.5 height)) | |
2041 (1.5 . ,(+ 1.0 height)) | |
2042 (2.0 . ,(+ 1.0 height))) | |
2043 cut))))) | |
2044 (slope-offset1 | |
2045 (get-slope-offset | |
2046 `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5)) | |
2047 `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7)))) | |
2048 (slope-offset2 | |
2049 (get-slope-offset | |
2050 `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1)) | |
2051 `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3))))) | |
2052 (list first-bezier second-bezier slope-offset1 slope-offset2))) | |
2053 | |
2054 (define | |
2055 (make-tilted-portion | |
2056 first-bezier | |
2057 second-bezier | |
2058 slope-offset1 | |
2059 slope-offset2 | |
2060 keylen | |
2061 bezier?) | |
2062 (append | |
2063 `((,(+ keylen (list-ref first-bezier 6)) | |
2064 ,(+ | |
2065 (* | |
2066 (car slope-offset1) | |
2067 (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1)))) | |
2068 ((if bezier? (lambda (x) `(,(apply append x))) return-x) | |
2069 `((,(+ (+ keylen 1.75) (list-ref first-bezier 6)) | |
2070 ,(+ | |
2071 (* | |
2072 (car slope-offset1) | |
2073 (+ (+ keylen 1.75) (list-ref first-bezier 6))) | |
2074 (cdr slope-offset1))) | |
2075 (,(+ (+ keylen 1.75) (list-ref second-bezier 0)) | |
2076 ,(+ | |
2077 (* | |
2078 (car slope-offset2) | |
2079 (+ (+ keylen 1.75) (list-ref second-bezier 0))) | |
2080 (cdr slope-offset2))) | |
2081 (,(+ keylen (list-ref second-bezier 0)) | |
2082 ,(+ | |
2083 (* (car slope-offset2) (+ keylen (list-ref second-bezier 0))) | |
2084 (cdr slope-offset2))))) | |
2085 `(,(list-head second-bezier 2)))) | |
2086 | |
2087 (define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?) | |
2088 (let* ((info-list (bassoon-bend-info-maker height gap cut)) | |
2089 (first-bezier (car info-list)) | |
2090 (second-bezier (cadr info-list)) | |
2091 (slope-offset1 (caddr info-list)) | |
2092 (slope-offset2 (cadddr info-list))) | |
2093 (rich-mcs-stencil | |
2094 (append | |
2095 `((0.0 ,(+ height gap)) | |
2096 ,(list-tail first-bezier 2)) | |
2097 (make-tilted-portion | |
2098 first-bezier | |
2099 second-bezier | |
2100 slope-offset1 | |
2101 slope-offset2 | |
2102 keylen | |
2103 bezier?) | |
2104 `(,(list-tail second-bezier 2) | |
2105 (1.0 0.0) | |
2106 (0.0 0.0))) | |
2107 d1 | |
2108 d2 | |
2109 proc))) | |
2110 | |
2111 (define (bassoon-uber-key-stencil height gap cut keylen d1 d2) | |
2112 (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 return-x #t)) | |
2113 | |
2114 (define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8)) | |
2115 | |
2116 (define bassoon-lh-he-key-stencil little-elliptical-key-stencil) | |
2117 | |
2118 (define bassoon-lh-hees-key-stencil little-elliptical-key-stencil) | |
2119 | |
2120 (define bassoon-lh-ees-key-stencil | |
2121 (rich-e-stencil | |
2122 1.2 | |
2123 0.6 | |
2124 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0)))) | |
2125 | |
2126 (define bassoon-lh-cis-key-stencil | |
2127 (rich-e-stencil | |
2128 1.0 | |
2129 0.5 | |
2130 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0)))) | |
2131 | |
2132 (define bassoon-lh-lbes-key-stencil | |
2133 (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6)) | |
2134 | |
2135 (define bassoon-lh-lb-key-stencil | |
2136 (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6)) | |
2137 | |
2138 (define bassoon-lh-lc-key-stencil | |
2139 (rich-pe-stencil 1.0 1.0 135 315 return-x)) | |
2140 | |
2141 (define bassoon-lh-ld-key-stencil | |
2142 (standard-mcs-stencil | |
2143 '((-0.8 4.0 1.4 4.0 0.6 0.0) | |
2144 (0.5 -0.5 0.5 -0.8 0.6 -1.0) | |
2145 (0.7 -1.2 0.8 -1.3 0.8 -1.8) | |
2146 (0.5 -1.8) | |
2147 (0.5 -1.4 0.4 -1.2 0.3 -1.1) | |
2148 (0.2 -1.0 0.1 -0.5 0.0 0.0)) | |
2149 1.0 | |
2150 1.0)) | |
2151 | |
2152 (define bassoon-lh-d-flick-key-stencil | |
2153 (let ((height 3.0)) | |
2154 (standard-mcs-stencil | |
2155 `((0.0 ,height) | |
2156 (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8)) | |
2157 (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0)) | |
2158 (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3)) | |
2159 (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1)) | |
2160 (0.4 0.0) | |
2161 (0.0 0.0)) | |
2162 -1.0 | |
2163 -1.0))) | |
2164 | |
2165 (define bassoon-lh-c-flick-key-stencil | |
2166 (let ((height 3.0)) | |
2167 (standard-mcs-stencil | |
2168 `((0.0 ,height) | |
2169 (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8)) | |
2170 (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0)) | |
2171 (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3)) | |
2172 (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1)) | |
2173 (0.4 0.0) | |
2174 (0.0 0.0)) | |
2175 -1.0 | |
2176 -1.0))) | |
2177 | |
2178 (define bassoon-lh-a-flick-key-stencil | |
2179 (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5)) | |
2180 | |
2181 (define bassoon-lh-thumb-cis-key-stencil | |
2182 (bassoon-uber-key-stencil 1.5 1.5 0.6 0.6 -0.6 0.6)) | |
2183 | |
2184 (define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7)) | |
2185 | |
2186 (define bassoon-rh-cis-key-stencil | |
2187 (rich-bassoon-uber-key-stencil | |
2188 1.1 | |
2189 1.5 | |
2190 0.9 | |
2191 0.3 | |
2192 0.5 | |
2193 0.5 | |
2194 (lambda (stencil) (ly:stencil-rotate stencil -76 0 0)) | |
2195 #t)) | |
2196 | |
2197 (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil) | |
2198 | |
2199 (define bassoon-rh-fis-key-stencil | |
2200 (rich-bassoon-uber-key-stencil 0.5 1.0 0.8 1.5 -0.7 0.7 return-x #f)) | |
2201 | |
2202 (define bassoon-rh-f-key-stencil | |
2203 (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5) | |
2204 (info-list (bassoon-bend-info-maker height gap cut)) | |
2205 (first-bezier (car info-list)) | |
2206 (second-bezier (cadr info-list)) | |
2207 (slope-offset1 (caddr info-list)) | |
2208 (slope-offset2 (cadddr info-list))) | |
2209 (standard-mcs-stencil | |
2210 (append | |
2211 (map | |
2212 (lambda (l) | |
2213 (rotunda-map | |
2214 - | |
2215 l | |
2216 (list-tail first-bezier 6))) | |
2217 (make-tilted-portion | |
2218 first-bezier | |
2219 second-bezier | |
2220 slope-offset1 | |
2221 slope-offset2 | |
2222 keylen | |
2223 #t)) | |
2224 '((0.0 0.0))) | |
2225 -0.7 | |
2226 0.7))) | |
2227 | |
2228 (define bassoon-rh-gis-key-stencil | |
2229 (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7)) | |
2230 | |
2231 (define bassoon-rh-thumb-bes-key-stencil | |
2232 (bassoon-uber-key-stencil 1.0 1.0 0.9 1.0 0.7 0.7)) | |
2233 | |
2234 (define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7)) | |
2235 | |
2236 (define bassoon-rh-thumb-fis-key-stencil | |
2237 (bassoon-uber-key-stencil 1.0 1.2 0.9 1.0 0.7 0.7)) | |
2238 | |
2239 (define bassoon-rh-thumb-gis-key-stencil | |
2240 (bassoon-uber-key-stencil 1.2 0.8 0.9 0.4 0.7 0.7)) | |
2241 | |
2242 (define bassoon-change-points | |
2243 ((make-named-spreadsheet '(bassoon contrabassoon)) | |
2244 `((left-hand-additional-keys . | |
2245 (((a . | |
2246 ((offset . (0.0 . -0.3)) | |
2247 (stencil . ,bassoon-lh-a-flick-key-stencil) | |
2248 (text? . ("A" . #f)) | |
2249 (complexity . trill))) | |
2250 (w . | |
2251 ((offset . (0.0 . 0.0)) | |
2252 (stencil . ,bassoon-lh-whisper-key-stencil) | |
2253 (text? . ("w" . #f)) | |
2254 (complexity . trill)))) | |
2255 ())) | |
2256 (right-hand-additional-keys . | |
2257 (((cis . | |
2258 ((offset . (0.0 . 0.0)) | |
2259 (stencil . ,bassoon-rh-cis-key-stencil) | |
2260 (text? . ("C" . 1)) | |
2261 (complexity . trill))) | |
2262 (thumb-gis . | |
2263 ((offset . (0.0 . 0.0)) | |
2264 (stencil . ,bassoon-rh-thumb-gis-key-stencil) | |
2265 (text? . ("G" . 1)) | |
2266 (complexity . trill)))) | |
2267 ())) | |
2268 (left-hand-flick-group . | |
2269 (((left-hand . d) (left-hand . c) (left-hand . a)) | |
2270 ((left-hand . d) (left-hand . c)))) | |
2271 (left-hand-thumb-group . | |
2272 (((left-hand . w) (left-hand . thumb-cis)) | |
2273 ((left-hand . thumb-cis)))) | |
2274 (cis-offset-instruction . | |
2275 (((,rich-group-extra-offset-rule | |
2276 ((right-hand . cis)) | |
2277 ,(append | |
2278 '((hidden . midline) (hidden . long-midline)) | |
2279 (make-central-column-hole-addresses '(four five six)) | |
2280 (make-left-hand-key-addresses | |
2281 '(low-b low-bes low-c low-d d a c w thumb-cis | |
2282 high-ees high-e cis ees))) | |
2283 (0.0 . 0.9))) | |
2284 ())) | |
2285 (right-hand-lower-thumb-group . | |
2286 (((right-hand . thumb-gis) (right-hand . thumb-fis)) | |
2287 ((right-hand . thumb-fis)))) | |
2288 (right-hand-cis-key . | |
2289 ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22))) | |
2290 ())) | |
2291 (back-left-hand-key-addresses . | |
2292 ((low-b low-bes low-c low-d d a c w thumb-cis) | |
2293 (low-b low-bes low-c low-d d c thumb-cis))) | |
2294 (front-right-hand-key-addresses . | |
2295 ((cis bes fis f gis) (bes fis f gis))) | |
2296 (back-right-hand-key-addresses . | |
2297 ((thumb-bes thumb-gis thumb-e thumb-fis) | |
2298 (thumb-bes thumb-e thumb-fis)))))) | |
2299 | |
2300 (define (generate-bassoon-family-entry bassoon-name) | |
2301 (let* | |
2302 ((change-points | |
2303 (get-named-spreadsheet-column bassoon-name bassoon-change-points))) | |
2304 `(,bassoon-name . | |
2305 ((keys . | |
2306 ((hidden . | |
2307 ((midline . | |
2308 ((offset . (0.0 . 0.0)) | |
2309 (stencil . ,midline-stencil) | |
2310 (text? . #f) | |
2311 (complexity . basic))) | |
2312 (long-midline . | |
2313 ((offset . (0.0 . 0.0)) | |
2314 (stencil . ,long-midline-stencil) | |
2315 (text? . #f) | |
2316 (complexity . basic))))) | |
2317 (central-column . | |
2318 ((one . | |
2319 ((offset . (0.0 . 1.0)) | |
2320 (stencil . ,bassoon-cc-one-key-stencil) | |
2321 (text? . #f) | |
2322 (complexity . trill))) | |
2323 (two . | |
2324 ((offset . (0.0 . 2.0)) | |
2325 (stencil . ,ring-column-circle-stencil) | |
2326 (text? . #f) | |
2327 (complexity . ring))) | |
2328 (three . | |
2329 ((offset . (0.0 . 3.0)) | |
2330 (stencil . ,ring-column-circle-stencil) | |
2331 (text? . #f) | |
2332 (complexity . ring))) | |
2333 (four . | |
2334 ((offset . (0.0 . 4.5)) | |
2335 (stencil . ,ring-column-circle-stencil) | |
2336 (text? . #f) | |
2337 (complexity . ring))) | |
2338 (five . | |
2339 ((offset . (0.0 . 5.5)) | |
2340 (stencil . ,ring-column-circle-stencil) | |
2341 (text? . #f) | |
2342 (complexity . ring))) | |
2343 (six . | |
2344 ((offset . (0.0 . 6.5)) | |
2345 (stencil . ,ring-column-circle-stencil) | |
2346 (text? . #f) | |
2347 (complexity . ring))))) | |
2348 (left-hand . | |
2349 ,(append | |
2350 (assoc-get 'left-hand-additional-keys change-points) | |
2351 `((high-e . | |
2352 ((offset . (0.0 . 0.0)) | |
2353 (stencil . ,bassoon-lh-he-key-stencil) | |
2354 (text? . ("hE" . #f)) | |
2355 (complexity . trill))) | |
2356 (high-ees . | |
2357 ((offset . (0.0 . 0.0)) | |
2358 (stencil . ,bassoon-lh-hees-key-stencil) | |
2359 (text? . ("hE" . 0)) | |
2360 (complexity . trill))) | |
2361 (ees . | |
2362 ((offset . (-1.0 . 1.0)) | |
2363 (stencil . ,bassoon-lh-ees-key-stencil) | |
2364 (text? . ("E" . 0)) | |
2365 (complexity . trill))) | |
2366 (cis . | |
2367 ((offset . (0.0 . 0.0)) | |
2368 (stencil . ,bassoon-lh-cis-key-stencil) | |
2369 (text? . ("C" . 1)) | |
2370 (complexity . trill))) | |
2371 (low-bes . | |
2372 ((offset . (0.0 . 0.0)) | |
2373 (stencil . ,bassoon-lh-lbes-key-stencil) | |
2374 (text? . ("b" . 0)) | |
2375 (complexity . trill))) | |
2376 (low-b . | |
2377 ((offset . (-1.0 . -0.7)) | |
2378 (stencil . ,bassoon-lh-lb-key-stencil) | |
2379 (text? . ("b" . #f)) | |
2380 (complexity . trill))) | |
2381 (low-c . | |
2382 ((offset . (0.0 . 0.0)) | |
2383 (stencil . ,bassoon-lh-lc-key-stencil) | |
2384 (text? . ("c" . #f)) | |
2385 (complexity . trill))) | |
2386 (low-d . | |
2387 ((offset . (0.0 . 0.0)) | |
2388 (stencil . ,bassoon-lh-ld-key-stencil) | |
2389 (text? . ("d" . #f)) | |
2390 (complexity . trill))) | |
2391 (d . | |
2392 ((offset . (-1.5 . 2.0)) | |
2393 (stencil . ,bassoon-lh-d-flick-key-stencil) | |
2394 (text? . ("D" . #f)) | |
2395 (complexity . trill))) | |
2396 (c . | |
2397 ((offset . (-0.8 . 1.1)) | |
2398 (stencil . ,bassoon-lh-c-flick-key-stencil) | |
2399 (text? . ("C" . #f)) | |
2400 (complexity . trill))) | |
2401 (thumb-cis . | |
2402 ((offset . (2.0 . -1.0)) | |
2403 (stencil . ,bassoon-lh-thumb-cis-key-stencil) | |
2404 (text? . ("C" . 1)) | |
2405 (complexity . trill)))))) | |
2406 (right-hand . | |
2407 ,(append | |
2408 (assoc-get 'right-hand-additional-keys change-points) | |
2409 `((bes . | |
2410 ((offset . (0.0 . 0.8)) | |
2411 (stencil . ,bassoon-rh-bes-key-stencil) | |
2412 (text? . ("B" . 0)) | |
2413 (complexity . trill))) | |
2414 (f . | |
2415 ((offset . (-2.2 . 4.35)) | |
2416 (stencil . ,bassoon-rh-f-key-stencil) | |
2417 (text? . ("F" . #f)) | |
2418 (complexity . trill))) | |
2419 (fis . | |
2420 ((offset . (1.5 . 1.0)) | |
2421 (stencil . ,bassoon-rh-fis-key-stencil) | |
2422 (text? . ("F" . 1)) | |
2423 (complexity . trill))) | |
2424 (gis . | |
2425 ((offset . (0.0 . -0.15)) | |
2426 (stencil . ,bassoon-rh-gis-key-stencil) | |
2427 (text? . ("G" . 1)) | |
2428 (complexity . trill))) | |
2429 (thumb-bes . | |
2430 ((offset . (0.0 . 0.0)) | |
2431 (stencil . ,bassoon-rh-thumb-bes-key-stencil) | |
2432 (text? . ("B" . 0)) | |
2433 (complexity . trill))) | |
2434 (thumb-e . | |
2435 ((offset . (1.75 . 0.4)) | |
2436 (stencil . ,bassoon-rh-thumb-e-key-stencil) | |
2437 (text? . ("E" . #f)) | |
2438 (complexity . trill))) | |
2439 (thumb-fis . | |
2440 ((offset . (-1.0 . 1.6)) | |
2441 (stencil . ,bassoon-rh-thumb-fis-key-stencil) | |
2442 (text? . ("F" . 1)) | |
2443 (complexity . trill)))))))) | |
2444 (graphical-commands . | |
2445 ((stencil-alist . | |
2446 ((stencils . | |
2447 ,(append | |
2448 (assoc-get 'right-hand-cis-key change-points) | |
2449 `(,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
2450 ,(simple-stencil-alist '(hidden . long-midline) '(0.0 . 3.80)) | |
2451 ((stencils . | |
2452 ,(make-central-column-hole-addresses | |
2453 '(one two three four five six))) | |
2454 (xy-scale-function . (,return-x . ,return-x)) | |
2455 (textual? . #f) | |
2456 (offset . (0.0 . 0.0))) | |
2457 ,(simple-stencil-alist '(left-hand . high-e) '(-1.0 . 7.0)) | |
2458 ,(simple-stencil-alist '(left-hand . high-ees) '(-1.0 . 6.0)) | |
2459 ((stencils . | |
2460 ((left-hand . ees) (left-hand . cis))) | |
2461 (xy-scale-function . (,return-1 . ,return-1)) | |
2462 (textual? . #f) | |
2463 (offset . (3.0 . 3.75))) | |
2464 ((stencils . | |
2465 (((stencils . | |
2466 ((left-hand . low-b) (left-hand . low-bes))) | |
2467 (xy-scale-function . (,return-1 . ,return-1)) | |
2468 (textual? . #f) | |
2469 (offset . (-2.0 . 9.0))) | |
2470 ((stencils . | |
2471 ,(assoc-get 'left-hand-flick-group change-points)) | |
2472 (xy-scale-function . (,return-1 . ,return-1)) | |
2473 (textual? . #f) | |
2474 (offset . (3.0 . 7.0))) | |
2475 ,(simple-stencil-alist '(left-hand . low-c) '(-1.0 . 4.5)) | |
2476 ,(simple-stencil-alist '(left-hand . low-d) '(-1.0 . 0.1)) | |
2477 ((stencils . | |
2478 ,(assoc-get 'left-hand-thumb-group change-points)) | |
2479 (xy-scale-function . (,return-1 . ,return-1)) | |
2480 (textual? . #f) | |
2481 (offset . (1.5 . -0.6))))) | |
2482 (xy-scale-function . (,return-1 . ,return-1)) | |
2483 (textual? . #f) | |
2484 (offset . (-5.5 . 4.7))) | |
2485 ,(simple-stencil-alist '(right-hand . bes) '(1.0 . 1.2)) | |
2486 ((stencils . | |
2487 ,(make-right-hand-key-addresses '(gis f fis))) | |
2488 (xy-scale-function . (,return-1 . ,return-1)) | |
2489 (textual? . #f) | |
2490 (offset . (2.0 . -1.25))) | |
2491 ((stencils . | |
2492 (((stencils . | |
2493 ((right-hand . thumb-bes) (right-hand . thumb-e))) | |
2494 (xy-scale-function . (,return-1 . ,return-1)) | |
2495 (textual? . #f) | |
2496 (offset . (-1.22 . 5.25))) | |
2497 ((stencils . | |
2498 ,(assoc-get 'right-hand-lower-thumb-group change-points)) | |
2499 (xy-scale-function . (,return-1 . ,return-1)) | |
2500 (textual? . #f) | |
2501 (offset . (0.0 . 0.0))))) | |
2502 (xy-scale-function . (,return-1 . ,return-1)) | |
2503 (textual? . #f) | |
2504 (offset . (-5.0 . 0.0)))))) | |
2505 (xy-scale-function . (,return-x . ,return-x)) | |
2506 (textual? . #f) | |
2507 (offset . (0.0 . 0.0)))) | |
2508 (draw-instructions . | |
2509 ((,apply-group-draw-rule-series | |
2510 (,(make-left-hand-key-addresses '(ees cis)) | |
2511 ,(make-left-hand-key-addresses | |
2512 (assoc-get 'back-left-hand-key-addresses change-points)) | |
2513 ,(make-right-hand-key-addresses '(f fis gis)) | |
2514 ,(make-right-hand-key-addresses | |
2515 (assoc-get 'back-right-hand-key-addresses change-points)))) | |
2516 (,group-automate-rule | |
2517 ,(make-central-column-hole-addresses '(one two three four five six))) | |
2518 (,bassoon-midline-rule | |
2519 ,(append | |
2520 (make-left-hand-key-addresses | |
2521 (assoc-get 'back-left-hand-key-addresses change-points)) | |
2522 (make-right-hand-key-addresses | |
2523 (assoc-get 'back-right-hand-key-addresses change-points)))))) | |
2524 (extra-offset-instructions . | |
2525 ,(append | |
2526 (assoc-get 'cis-offset-instruction change-points) | |
2527 `((,uniform-extra-offset-rule (0.0 . 0.0))))))) | |
2528 (text-commands . | |
2529 ((stencil-alist . | |
2530 ((stencils . | |
2531 (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) | |
2532 ((stencils . | |
2533 ,(make-central-column-hole-addresses | |
2534 '(one two three four five six))) | |
2535 (xy-scale-function . (,return-x . ,return-x)) | |
2536 (textual? . #f) | |
2537 (offset . (0.0 . 0.0))) | |
2538 ((stencils . | |
2539 ,(make-left-hand-key-addresses '(high-e high-ees ees cis))) | |
2540 (textual? . ,lh-woodwind-text-stencil) | |
2541 (offset . (1.5 . 3.75))) | |
2542 ((stencils . | |
2543 ,(make-left-hand-key-addresses | |
2544 (assoc-get 'back-left-hand-key-addresses change-points))) | |
2545 (textual? . ,rh-woodwind-text-stencil) | |
2546 (offset . (-1.25 . 3.75))) | |
2547 ((stencils . | |
2548 ,(make-right-hand-key-addresses | |
2549 (assoc-get 'front-right-hand-key-addresses change-points))) | |
2550 (textual? . ,lh-woodwind-text-stencil) | |
2551 (offset . (1.5 . 0.0))) | |
2552 ((stencils . | |
2553 ,(make-right-hand-key-addresses | |
2554 (assoc-get 'back-right-hand-key-addresses change-points))) | |
2555 (textual? . ,rh-woodwind-text-stencil) | |
2556 (offset . (-1.25 . 0.0))))) | |
2557 (xy-scale-function . (,return-x . ,return-x)) | |
2558 (textual? . #f) | |
2559 (offset . (0.0 . 0.0)))) | |
2560 (draw-instructions . | |
2561 ((,apply-group-draw-rule-series | |
2562 (,(make-left-hand-key-addresses | |
2563 (assoc-get 'back-left-hand-key-addresses change-points)) | |
2564 ,(make-right-hand-key-addresses | |
2565 (assoc-get 'front-right-hand-key-addresses change-points)) | |
2566 ,(make-right-hand-key-addresses | |
2567 (assoc-get 'back-right-hand-key-addresses change-points)) | |
2568 ,(make-left-hand-key-addresses '(high-e high-ees ees cis)))) | |
2569 (,group-automate-rule | |
2570 ,(make-central-column-hole-addresses '(one two three four five six))) | |
2571 (,group-automate-rule ((hidden . midline))))) | |
2572 (extra-offset-instructions . | |
2573 ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) | |
2574 | |
2575 ;; Assembly functions | |
2576 | |
2577 ; Scans a bank for name. | |
2578 ; for example, '(left-hand . bes) will return bes in the left-hand | |
2579 ; of a given bank | |
2580 (define (get-key name bank) | |
2581 (assoc-get (cdr name) (assoc-get (car name) bank))) | |
2582 | |
2583 (define (translate-key-instruction key-instruction) | |
2584 (let* | |
2585 ((key-name (car key-instruction)) | |
2586 (key-complexity (assoc-get 'complexity (cdr key-instruction)))) | |
2587 (cond | |
2588 ((eqv? key-complexity 'basic) | |
2589 `((,key-name . ,(assoc-get 'F HOLE-FILL-LIST)))) | |
2590 ((eqv? key-complexity 'trill) | |
2591 (make-symbol-alist key-name #t #f)) | |
2592 ((eqv? key-complexity 'covered) | |
2593 (make-symbol-alist key-name #f #f)) | |
2594 ((eqv? key-complexity 'ring) | |
2595 (make-symbol-alist key-name #f #t))))) | |
2596 | |
2597 (define (update-possb-list input-key possibility-list cannonic-list) | |
Neil Puttock
2010/05/31 14:48:13
canonic-list
| |
2598 (if (null? possibility-list) | |
2599 (throw | |
Neil Puttock
2010/05/31 14:48:13
use ly:error or ly:warning
| |
2600 'markup-format | |
2601 "woodwind markup error - invalid key or hole requested" | |
2602 input-key) | |
2603 (if | |
2604 (assoc-get input-key (cdar possibility-list)) | |
2605 (append | |
2606 `(((,(caaar possibility-list) . | |
2607 ,(assoc-get input-key (cdar possibility-list))) . | |
2608 ,(assoc-get (caar possibility-list) cannonic-list))) | |
2609 (assoc-remove (caar possibility-list) cannonic-list)) | |
2610 (update-possb-list input-key (cdr possibility-list) cannonic-list)))) | |
2611 | |
2612 (define (key-crawler input-list possibility-list) | |
2613 (if (null? input-list) | |
2614 (map car possibility-list) | |
2615 (key-crawler | |
2616 (cdr input-list) | |
2617 (update-possb-list | |
2618 (car input-list) | |
2619 possibility-list | |
2620 possibility-list)))) | |
2621 | |
2622 (define (translate-draw-instructions input-alist key-name-alist) | |
2623 (apply append | |
2624 (map | |
2625 (lambda | |
2626 (short long) | |
2627 (let* | |
2628 ((key-instructions | |
2629 (map | |
2630 (lambda | |
2631 (instr) | |
2632 `(((,long . ,(car instr)) . 0) . | |
2633 ,(translate-key-instruction instr))) | |
2634 (assoc-get long key-name-alist)))) | |
2635 (key-crawler (assoc-get short input-alist) key-instructions))) | |
2636 '(hd cc lh rh) | |
2637 '(hidden central-column left-hand right-hand)))) | |
2638 | |
2639 (define (uniform-draw-instructions key-name-alist) | |
2640 (apply append | |
2641 (map | |
2642 (lambda | |
2643 (long) | |
2644 (map | |
2645 (lambda | |
2646 (key-instructions) | |
2647 `((,long . ,(car key-instructions)) . 1)) | |
2648 (assoc-get long key-name-alist))) | |
2649 '(hidden central-column left-hand right-hand)))) | |
2650 | |
2651 (define (list-all-possible-keys key-name-alist) | |
2652 (map | |
2653 (lambda | |
2654 (short long) | |
2655 `(,short . ,(map | |
2656 (lambda | |
2657 (key-instructions) | |
2658 (car key-instructions)) | |
2659 (assoc-get long key-name-alist)))) | |
2660 '(cc lh rh) | |
2661 '(central-column left-hand right-hand))) | |
2662 | |
2663 (define (list-all-possible-keys-verbose key-name-alist) | |
2664 (map | |
2665 (lambda | |
2666 (short long) | |
2667 `(,short . ,(map | |
2668 (lambda | |
2669 (key-instructions) | |
2670 `(,(car key-instructions) . | |
2671 ,(map | |
2672 (lambda | |
2673 (x) | |
2674 (car x)) | |
2675 (translate-key-instruction key-instructions)))) | |
2676 (assoc-get long key-name-alist)))) | |
2677 '(cc lh rh) | |
2678 '(central-column left-hand right-hand))) | |
2679 | |
2680 (define woodwind-data-assembly-instructions | |
2681 `((,generate-flute-family-entry . piccolo) | |
2682 (,generate-flute-family-entry . flute) | |
2683 (,generate-oboe-family-entry . oboe) | |
2684 (,generate-clarinet-family-entry . clarinet) | |
2685 (,generate-clarinet-family-entry . bass-clarinet) | |
2686 (,generate-saxophone-family-entry . saxophone) | |
2687 (,generate-bassoon-family-entry . bassoon) | |
2688 (,generate-bassoon-family-entry . contrabassoon))) | |
2689 | |
2690 (define-public woodwind-instrument-list | |
2691 (map | |
2692 (lambda (instruction) | |
2693 (cdr instruction)) | |
2694 woodwind-data-assembly-instructions)) | |
2695 | |
2696 (define woodwind-data-alist | |
2697 (map | |
2698 (lambda (instruction) | |
2699 ((car instruction) (cdr instruction))) | |
2700 woodwind-data-assembly-instructions)) | |
2701 | |
2702 ;;; The brains of the markup function: takes drawing and offset information | |
2703 ;;; about a key region and calls the appropriate stencils to draw the region. | |
2704 | |
2705 | |
2706 ; now that is unnested, need to find a way to feed info... | |
2707 (define | |
2708 (assemble-stencils | |
2709 stencil-alist | |
2710 key-bank | |
2711 draw-instructions | |
2712 extra-offset-instructions | |
2713 radius | |
2714 thick | |
2715 xy-stretch | |
2716 layout | |
2717 props) | |
2718 (apply | |
2719 ly:stencil-add | |
2720 (map | |
2721 (lambda | |
2722 (node) | |
2723 (ly:stencil-translate | |
2724 (if (pair? (cdr node)) | |
2725 (if (assoc-get 'textual? node) | |
2726 ((assoc-get 'textual? node) | |
2727 (map | |
2728 (lambda (key) (assoc-get 'text? key)) | |
2729 (map | |
2730 (lambda (instr) (get-key instr key-bank)) | |
2731 (assoc-get 'stencils node))) | |
2732 radius | |
2733 (map | |
2734 (lambda (key) (assoc-get key draw-instructions)) | |
2735 (assoc-get 'stencils node)) | |
2736 layout | |
2737 props) | |
2738 (assemble-stencils | |
2739 node | |
2740 key-bank | |
2741 draw-instructions | |
2742 extra-offset-instructions | |
2743 radius | |
2744 thick | |
2745 (interval-apply | |
2746 (assoc-get 'xy-scale-function stencil-alist) | |
2747 xy-stretch) | |
2748 layout | |
2749 props)) | |
2750 (if (= 0 (assoc-get node draw-instructions)) | |
2751 empty-stencil | |
2752 ((assoc-get 'stencil (get-key node key-bank)) | |
2753 radius | |
2754 thick | |
2755 (assoc-get node draw-instructions) | |
2756 layout | |
2757 props))) | |
2758 (interval-scale | |
2759 (interval-translate | |
2760 (interval-scale | |
2761 (assoc-get | |
2762 'offset | |
2763 (if (pair? (cdr node)) | |
2764 node | |
2765 (get-key node key-bank))) | |
2766 (interval-apply | |
2767 (assoc-get 'xy-scale-function stencil-alist) | |
2768 xy-stretch)) | |
2769 (if | |
2770 (assoc-get node extra-offset-instructions) | |
2771 (assoc-get node extra-offset-instructions) | |
2772 '(0.0 . 0.0))) | |
2773 radius))) | |
2774 (assoc-get 'stencils stencil-alist)))) | |
2775 | |
2776 (define-public (print-keys instrument) | |
2777 (let* | |
2778 ((chosen-instrument | |
2779 (begin | |
2780 (format #t "\nPrinting keys for: ~a\n" instrument) | |
2781 (assoc-get instrument woodwind-data-alist))) | |
2782 (key-list (list-all-possible-keys (assoc-get 'keys chosen-instrument)))) | |
2783 (define (key-list-loop key-list) | |
2784 (if (null? key-list) | |
2785 0 | |
2786 (begin | |
2787 (format #t "~a\n ~a\n" (caar key-list) (cdar key-list)) | |
2788 (key-list-loop (cdr key-list))))) | |
2789 (key-list-loop key-list))) | |
2790 | |
2791 (define-public (get-woodwind-key-list instrument) | |
2792 (list-all-possible-keys-verbose | |
2793 (assoc-get | |
2794 'keys | |
2795 (assoc-get instrument woodwind-data-alist)))) | |
2796 | |
2797 (define-public (print-keys-verbose instrument) | |
2798 (let* | |
2799 ((chosen-instrument | |
2800 (begin | |
2801 (format #t "\nPrinting keys in verbose mode for: ~a\n" instrument) | |
2802 (assoc-get instrument woodwind-data-alist))) | |
2803 (key-list | |
2804 (list-all-possible-keys-verbose (assoc-get 'keys chosen-instrument)))) | |
2805 (define (key-list-loop key-list) | |
2806 (if (null? key-list) | |
2807 0 | |
2808 (begin | |
2809 (format #t "~a\n" (caar key-list)) | |
2810 (map | |
2811 (lambda | |
2812 (x) | |
2813 (format #t " possibilities for ~a:\n ~a\n" (car x) (cdr x))) | |
2814 (cdar key-list)) | |
2815 (key-list-loop (cdr key-list))))) | |
2816 (key-list-loop key-list))) | |
2817 | |
2818 (define-markup-command | |
2819 (woodwind-diagram layout props instrument input-list) | |
2820 (symbol? list?) | |
2821 #:category instrument-specific-markup ; markup category | |
2822 "Make a woodwind-instrument diagram. For example, say | |
2823 | |
2824 @example | |
2825 \\markup \\woodwind-diagram #'oboe #'(1.4 0.1 #t ((lh . (d ees)) (cc . (five3qT1 q)) (rh . (gis)))) | |
2826 @end example | |
2827 | |
2828 @noindent | |
2829 for an oboe with the left-hand d key, left-hand ees key, | |
2830 and right-hand gis key depressed while the five-hole of | |
2831 the central column effectuates a trill between 1/4 and 3/4 closed. | |
2832 | |
2833 The following instruments are supported: | |
Neil Puttock
2010/05/31 14:48:13
you need to catch invalid instrument names
| |
2834 @itemize @minus | |
2835 | |
2836 @item | |
2837 piccolo | |
2838 | |
2839 @item | |
2840 flute | |
2841 | |
2842 @item | |
2843 oboe | |
2844 | |
2845 @item | |
2846 clarinet | |
2847 | |
2848 @item | |
2849 bass-clarinet | |
2850 | |
2851 @item | |
2852 saxophone | |
2853 | |
2854 @item | |
2855 bassoon | |
2856 | |
2857 @item | |
2858 contrabassoon | |
2859 | |
2860 @end itemize | |
2861 | |
2862 To see all of the callable keys for a given instrument, | |
2863 include the function @code{(print-keys 'instrument)} | |
2864 in your .ly file, where instrument is the instrument | |
2865 whose keys you want to print. | |
2866 | |
2867 Certain keys allow for special configurations. The entire gamut of | |
2868 configurations possible is as follows: | |
2869 | |
2870 @itemize @minus | |
2871 | |
2872 @item | |
2873 1q (1/4 covered) | |
2874 | |
2875 @item | |
2876 1h (1/2 covered) | |
2877 | |
2878 @item | |
2879 3q (3/4 covered) | |
2880 | |
2881 @item | |
2882 R (ring depressed) | |
2883 | |
2884 @item | |
2885 F (fully covered; the default if no state put) | |
2886 | |
2887 @end itemize | |
2888 | |
2889 Additionally, these configurations can be used in trills. So, for example, | |
2890 @code{three3qTR} effectuates a trill between 3/4 full and ring depressed | |
2891 on the three hole. As another example, @code{threeRT} effectuates a trill | |
2892 between R and open, whereas @code{threeTR} effectuates a trill between open | |
2893 and shut. To see all of the possibilities for all of the keys of a given | |
2894 instrument, invoke @code{(print-keys-verbose 'instrument)}. | |
2895 | |
2896 Lastly, substituting an empty list for the pressed-key alist will result in | |
2897 a diagram with all of the keys drawn but none filled. ie... | |
2898 | |
2899 @example | |
2900 \\markup \\woodwind-diagram #'oboe #'(1.4 0.1 #t ()) | |
2901 @end example" | |
2902 (let* ((radius (car input-list)) | |
2903 (thick (cadr input-list)) | |
2904 (display-graphic (caddr input-list)) | |
2905 (xy-stretch `(1.0 . 2.5)) | |
2906 (chosen-instrument (assoc-get instrument woodwind-data-alist)) | |
2907 (stencil-info | |
2908 (assoc-get | |
2909 (if display-graphic 'graphical-commands 'text-commands) | |
2910 chosen-instrument)) | |
2911 (user-draw-commands (cadddr input-list)) | |
2912 (pressed-info | |
2913 (if (null? user-draw-commands) | |
2914 (uniform-draw-instructions (assoc-get 'keys chosen-instrument)) | |
2915 (translate-draw-instructions | |
2916 (append '((hd . ())) user-draw-commands) | |
2917 (assoc-get 'keys chosen-instrument)))) | |
2918 (draw-info | |
2919 (function-chain | |
2920 pressed-info | |
2921 (assoc-get 'draw-instructions stencil-info))) | |
2922 (extra-offset-info | |
2923 (function-chain | |
2924 pressed-info | |
2925 (assoc-get 'extra-offset-instructions stencil-info)))) | |
2926 (interpret-markup layout props | |
2927 (markup #:stencil | |
2928 (assemble-stencils | |
Neil Puttock
2010/05/31 14:48:13
markup commands return stencils, so (assemble-sten
| |
2929 (assoc-get 'stencil-alist stencil-info) | |
2930 (assoc-get 'keys chosen-instrument) | |
2931 draw-info | |
2932 extra-offset-info | |
2933 radius | |
2934 thick | |
2935 xy-stretch | |
2936 layout | |
2937 props))))) | |
OLD | NEW |