Rietveld Code Review Tool
Help | Bug tracker | Discussion group | Source code | Sign in
(801)

Side by Side Diff: scm/woodwind-diagrams.scm

Issue 1425041: Woodwind diagrams (Closed)
Patch Set: Created 13 years, 10 months ago
Left:
Right:
Use n/p to move between diff chunks; N/P to move between comments. Please Sign in to add in-line comments.
Jump to:
View unified diff | Download patch
« scm/stencil.scm ('K') | « scm/stencil.scm ('k') | no next file » | no next file with comments »
Toggle Intra-line Diffs ('i') | Expand Comments ('e') | Collapse Comments ('c') | Show Comments Hide Comments ('s')
OLDNEW
(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)))))
OLDNEW
« scm/stencil.scm ('K') | « scm/stencil.scm ('k') | no next file » | no next file with comments »

Powered by Google App Engine
RSS Feeds Recent Issues | This issue
This is Rietveld f62528b