1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2010--2012 Mike Solomon <mikesol@stanfordalumni.org>
4 ;;;; Clarinet drawings copied from diagrams created by
5 ;;;; Gilles Thibault <gilles.thibault@free.fr>
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.
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.
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/>.
20 (define HOLE-FILL-LIST '((R . 3) (1q . 5) (1h . 7) (3q . 11) (F . 13)))
24 (define-public (symbol-concatenate . names)
25 "Like @code{string-concatenate}, but for symbols."
26 (string->symbol (apply string-append (map symbol->string names))))
28 (define-public (function-chain arg function-list)
29 "Applies a list of functions in @var{function-list} to @var{arg}.
30 Each element of @var{function-list} is structured @code{(cons function
31 '(arg2 arg3 ...))}. If function takes arguments besides @var{arg}, they
32 are provided in @var{function-list}.
34 Example: Executing @samp{(function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
36 (if (null? function-list)
39 (apply (caar function-list) (append `(,arg) (cdar function-list)))
40 (cdr function-list))))
42 (define (rotunda-map function inlist rotunda)
43 "Like map, but with a rotating last argument to function.
45 @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))}
47 (define (rotunda-map-chain function inlist outlist rotunda)
53 (append outlist (list (function (car inlist) (car rotunda))))
54 (append (cdr rotunda) (list (car rotunda))))))
55 (rotunda-map-chain function inlist '() rotunda))
57 (define (assoc-keys alist)
58 "Gets the keys of an alist."
59 (map (lambda (x) (car x)) alist))
61 (define (assoc-values alist)
62 "Gets the values of an alist."
63 (map (lambda (x) (cdr x)) alist))
65 (define (get-slope-offset p1 p2)
66 "Gets the slope and offset for p1 and p2.
68 @code{(get-slope-offset '(1 . 2) '(3 . -5.1))}
69 @code{(-3.55 . 5.55)}"
71 ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2))))
72 (offset (- (cdr p1) (* slope (car p1)))))
75 (define (is-square? x input-list)
76 "Returns true if x is the square of a value in input-list."
77 (pair? (memv (inexact->exact (sqrt x)) input-list)))
79 (define (satisfies-function? function input-list)
80 "Returns true if an element in @code{input-list} is true
81 when @code{function} is applied to it.
83 @code{guile> (satisfies-function? null? '((1 2) ()))}
85 @code{guile> (satisfies-function? null? '((1 2) (3)))}
87 (if (null? input-list)
89 (or (function (car input-list))
90 (satisfies-function? function (cdr input-list)))))
92 (define (true-entry? input-list)
93 "Is there a true entry in @code{input-list}?"
94 (satisfies-function? identity input-list))
96 (define (entry-greater-than-x? input-list x)
97 "Is there an entry greater than @code{x} in @code{input-list}?"
98 (satisfies-function? (lambda (y) (> y x)) input-list))
100 (define (n-true-entries input-list)
101 "Returns number of true entries in @code{input-list}."
102 (reduce + 0 (map (lambda (x) (if x 1 0)) input-list)))
104 (define (bezier-head-for-stencil bezier cut-point)
105 "Prepares a split-bezier to be used in a connected path stencil."
106 (list-tail (flatten-list (car (split-bezier bezier cut-point))) 2))
108 ;; Translators for keys
110 ; Translates a "normal" key (open, closed, trill)
111 (define (key-fill-translate fill)
115 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
116 ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t)))
118 ; Similar to above, but trans vs opaque doesn't matter
119 (define (text-fill-translate fill)
122 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
123 ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0)))
125 ; Emits a list for the central-column-hole maker
126 ; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?)
127 ; Multiple values, such as (#t #f #f #t #f), mean a trill between
128 ; not-full and 3-quarters-full
129 (define (process-fill-value fill)
130 (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1)))
131 (append `(,(or (< fill 3) (is-square? fill avals)))
132 (map (lambda (x) (= 0 (remainder fill x))) avals))))
134 ; Color a stencil gray
135 (define (gray-colorize stencil)
136 (apply ly:stencil-in-color (cons stencil (x11-color 'grey))))
138 ; A connected path stencil that is surrounded by proc
139 (define (rich-path-stencil ls x-stretch y-stretch proc)
140 (lambda (radius thick fill layout props)
142 ((fill-translate (key-fill-translate fill))
143 (gray? (eqv? fill-translate 0.5)))
145 ((if gray? gray-colorize identity)
147 (make-connected-path-stencil
153 (if gray? #t fill-translate))))
156 ((rich-path-stencil ls x-stretch y-stretch proc)
163 ; A connected path stencil without a surrounding proc
164 (define (standard-path-stencil ls x-stretch y-stretch)
165 (rich-path-stencil ls x-stretch y-stretch identity))
167 ; An ellipse stencil that is surrounded by a proc
168 (define (rich-pe-stencil x-stretch y-stretch start end proc)
169 (lambda (radius thick fill layout props)
171 ((fill-translate (key-fill-translate fill))
172 (gray? (eqv? fill-translate 0.5)))
174 ((if gray? gray-colorize identity)
176 (make-partial-ellipse-stencil
183 (if gray? #t fill-translate))))
186 ((rich-pe-stencil x-stretch y-stretch start end proc)
193 (define (rich-e-stencil x-stretch y-stretch proc)
194 (lambda (radius thick fill layout props)
196 ((fill-translate (key-fill-translate fill))
197 (gray? (eqv? fill-translate 0.5)))
199 ((if gray? gray-colorize identity)
201 (make-ellipse-stencil
205 (if gray? #t fill-translate))))
208 ((rich-e-stencil x-stretch y-stretch proc)
215 ; An ellipse stencil without a surrounding proc
216 (define (standard-e-stencil x-stretch y-stretch)
217 (rich-e-stencil x-stretch y-stretch identity))
219 ; Translates all possible representations of symbol.
220 ; If simple? then the only representations are open, closed, and trill.
221 ; Otherwise, there can be various levels of "closure" on the holes
222 ; ring? allows for a ring around the holes as well
223 (define (make-symbol-alist symbol simple? ring?)
228 `(,(symbol-concatenate symbol 'T 'F) .
229 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))))
231 `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
232 (,(symbol-concatenate symbol 'T) .
233 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))
239 `((,(symbol-concatenate symbol (car x) 'T)
241 (,(symbol-concatenate symbol 'T (car x))
242 . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
243 (,(symbol-concatenate symbol (car x))
248 `(,(symbol-concatenate symbol
252 . ,(* (cdr a) (cdr b))))
254 (cdr (member x HOLE-FILL-LIST))))))
255 (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST))))))))
257 ;;; Commands for text layout
259 ; Draws a circle around markup if (= trigger 0.5)
260 (define-markup-command
261 (conditional-circle-markup layout props trigger in-markup)
263 (interpret-markup layout props
264 (if (eqv? trigger 0.5)
265 (markup #:circle (markup in-markup))
266 (markup in-markup))))
268 ; Makes a list of named-keys
269 (define (make-name-keylist input-list key-list font-size)
272 (markup #:conditional-circle-markup
276 (markup #:abs-fontsize font-size (car y))
277 (if (and (< x 1) (cdr y))
297 input-list key-list))
299 ; Makes a list of number-keys
300 (define (make-number-keylist input-list key-list font-size)
304 #:conditional-circle-markup
306 (markup #:abs-fontsize font-size #:number y))
311 ; Creates a named-key list with a certain alignment
312 (define (aligned-text-stencil-function dir hv)
313 (lambda (key-name-list radius fill-list layout props)
317 (make-general-align-markup
320 ((if hv make-concat-markup make-center-column-markup)
322 (map text-fill-translate fill-list)
326 (define number-column-stencil
327 (lambda (key-name-list radius fill-list layout props)
331 (make-general-align-markup
334 (make-general-align-markup
337 (make-override-markup
341 (map text-fill-translate fill-list)
345 ; Utility function for the left-hand keys
346 (define lh-woodwind-text-stencil
347 (aligned-text-stencil-function LEFT #t))
349 ; Utility function for the right-hand keys
350 (define rh-woodwind-text-stencil
351 (aligned-text-stencil-function RIGHT #t))
353 (define octave-woodwind-text-stencil
354 (aligned-text-stencil-function CENTER #f))
358 (define (rich-group-draw-rule alist target-part change-part)
360 (entry-greater-than-x?
361 (map (lambda (key) (assoc-get key alist)) target-part) 3)
362 (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist)
365 (define (bassoon-midline-rule alist target-part)
367 (entry-greater-than-x?
368 (map (lambda (key) (assoc-get key alist)) target-part) 0)
369 (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist)
370 (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist)))
372 (define (group-draw-rule alist target-part)
373 (rich-group-draw-rule alist target-part target-part))
375 (define (group-automate-rule alist change-part)
376 (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist))
378 (define (apply-group-draw-rule-series alist target-part-list)
379 (if (null? target-part-list)
381 (apply-group-draw-rule-series
382 (group-draw-rule alist (car target-part-list))
383 (cdr target-part-list))))
385 ;; Extra-offset rules
387 (define (rich-group-extra-offset-rule alist target-part change-part eos)
389 (entry-greater-than-x?
390 (map (lambda (key) (assoc-get key alist)) target-part) 0)
391 (map-selected-alist-keys (lambda (x) eos) change-part alist)
394 (define (group-extra-offset-rule alist target-part eos)
395 (rich-group-extra-offset-rule alist target-part target-part eos))
397 (define (uniform-extra-offset-rule alist eos)
398 (map-selected-alist-keys
399 (lambda (x) (if (pair? x) x eos))
403 ;;; General drawing commands
405 ; Used all the time for a dividing line
406 (define (midline-stencil radius thick fill layout props)
407 (make-line-stencil (* thick 2) (* -0.80 radius) 0 (* 0.80 radius) 0))
409 (define (long-midline-stencil radius thick fill layout props)
410 (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0))
412 ; Used all the time for a small, between-hole key
413 (define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2))
415 ; Used for several upper keys in the clarinet and sax
416 (define (upper-key-stencil tailw tailh bodyw bodyh)
418 ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2))))))
419 (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05)))))))
420 (standard-path-stencil
436 ,(- -0.025 (/ tailh 2))
442 ; Utility function for the column-hole maker.
443 ; Returns the left and right degrees for the drawing of a given
444 ; fill level (1-quarter, 1-half, etc...)
445 (define (degree-first-true fill-list left? reverse?)
446 (define (dfl-crawler fill-list os-list left?)
448 ((if left? car cdr) (car os-list))
449 (dfl-crawler (cdr fill-list) (cdr os-list) left?)))
451 ((if reverse? reverse identity) fill-list)
452 ((if reverse? reverse identity)
453 '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90)))
456 ; Gets the position of the first (or last if reverse?) element of a list.
457 (define (position-true-endpoint in-list reverse?)
458 (define (pte-crawler in-list n)
461 (pte-crawler (cdr in-list) (+ n 1))))
463 (if reverse? (length in-list) 0)
464 (pte-crawler ((if reverse? reverse identity) in-list) 0)))
466 ; Huge, kind-of-ugly maker of a circle in a column.
467 ; I think this is the clearest way to write it, though...
469 (define (column-circle-stencil radius thick fill layout props)
470 (let* ((fill-list (process-fill-value fill)))
473 (list-ref fill-list 0)
474 (not (true-entry? (list-tail fill-list 1)))) ; is it empty?
475 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
477 (list-ref fill-list 4)
478 (not (true-entry? (list-head fill-list 4)))) ; is it full?
479 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
481 (list-ref fill-list 0)
482 (list-ref fill-list 4)) ; is it a trill between empty and full?
483 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
484 (else ;If none of these, it is partially full.
486 ((rich-pe-stencil 1.0 1.0 0 360 identity)
489 (if (list-ref fill-list 4)
490 (expt (assoc-get 'F HOLE-FILL-LIST) 2)
497 (degree-first-true fill-list #t #t)
498 (degree-first-true fill-list #f #t)
504 (list-head fill-list (position-true-endpoint fill-list #t)))
505 (expt (assoc-get 'F HOLE-FILL-LIST) 2)
506 (assoc-get 'F HOLE-FILL-LIST))
510 (= 2 (n-true-entries (list-tail fill-list 1))) ; trill?
514 (degree-first-true fill-list #t #f)
515 (degree-first-true fill-list #f #f)
519 (assoc-get 'F HOLE-FILL-LIST)
524 (define (variable-column-circle-stencil scaler)
525 (lambda (radius thick fill layout props)
526 (column-circle-stencil (* radius scaler) thick fill layout props)))
528 ; A stencil for ring-column circles that combines two of the above
529 (define (ring-column-circle-stencil radius thick fill layout props)
530 (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST)))
533 (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
537 (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))
538 (* (+ (- 1.0 (* 2 thick)) (/ thick 2))))
540 (* (* 4 radius) thick)
544 ((standard-e-stencil 1.0 1.0) radius thick 1 layout props)
545 (column-circle-stencil
546 (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2))
549 (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST)))
550 (assoc-get 'F HOLE-FILL-LIST)
552 (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
553 (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
554 (/ fill (assoc-get 'R HOLE-FILL-LIST))))
557 (column-circle-stencil radius thick fill layout props)))
559 ;;; Flute family stencils
561 (define flute-lh-b-key-stencil
562 (standard-path-stencil
564 (0 1.625 -0.125 1.75 -0.25 1.75)
565 (-0.55 1.75 -0.55 0.95 -0.25 0.7)
570 (define flute-lh-bes-key-stencil
571 (standard-path-stencil
573 (0 1.625 -0.125 1.75 -0.25 1.75)
574 (-0.55 1.75 -0.55 0.95 -0.25 0.7)
579 (define (flute-lh-gis-rh-bes-key-stencil deg)
581 '((0.1 0.1 0.2 0.4 0.3 0.6)
582 (0.3 1.0 0.8 1.0 0.8 0.7)
583 (0.8 0.3 0.5 0.3 0 0))
586 (lambda (stencil) (ly:stencil-rotate stencil deg 0 0))))
588 (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0))
590 (define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200))
592 (define flute-rh-d-key-stencil little-elliptical-key-stencil)
594 (define flute-rh-dis-key-stencil little-elliptical-key-stencil)
596 (define flute-rh-ees-key-stencil
597 (standard-path-stencil
598 '((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))
602 (define (piccolo-rh-x-key-stencil radius thick fill layout props)
606 (make-general-align-markup
611 `(,(text-fill-translate fill))
615 (define flute-lower-row-stretch 1.4)
617 (define flute-rh-cis-key-stencil
618 (standard-path-stencil
619 '((0 0.75) (-0.8 0.75 -0.8 0 0 0))
620 flute-lower-row-stretch
621 flute-lower-row-stretch))
623 (define flute-rh-c-key-stencil
624 (standard-path-stencil
625 '((0 0.75) (0.4 0.75) (0.4 0) (0 0))
626 flute-lower-row-stretch
627 flute-lower-row-stretch))
629 (define flute-rh-b-key-stencil
630 (standard-path-stencil
631 '((0 0.75) (0.25 0.75) (0.25 0) (0 0))
632 flute-lower-row-stretch
633 flute-lower-row-stretch))
635 (define flute-rh-gz-key-stencil
637 '((0.1 0.1 0.4 0.2 0.6 0.3)
638 (1.0 0.3 1.0 0.8 0.7 0.8)
639 (0.3 0.8 0.3 0.5 0 0))
640 flute-lower-row-stretch
641 flute-lower-row-stretch
642 (lambda (stencil) (ly:stencil-rotate stencil 160 0 0))))
644 ;;; Shared oboe/clarinet stencils
646 (define (oboe-lh-gis-lh-low-b-key-stencil gis?)
654 `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0))
659 `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
662 (standard-path-stencil
665 `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0))
670 (coord-rotate x (atan (/ y (* 2 0.25))))
673 `(((0 . ,y) (,x . ,y) (,x . 0))
674 ((,x . ,(- y)) (0 . ,(- y)) (0 . 0)))))
675 `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0)))
678 (standard-path-stencil
682 (coord-rotate x (atan (/ y (* 2 0.25)))))
684 `(,(list-tail up-part 1)
685 ,(list-head down-part 1)
686 ,(list-tail down-part 1)))
688 (- scaling-factor)))))
690 (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t))
692 (define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f))
694 (define (oboe-lh-ees-lh-bes-key-stencil ees?)
695 (standard-path-stencil
697 (0 1.625 -0.125 1.75 -0.25 1.75)
698 (-0.5 1.75 -0.5 0.816 -0.25 0.5)
700 (0 ,(if ees? -0.6 -0.3)))
701 (* (if ees? -1.0 1.0) -1.8)
704 (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t))
706 (define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f))
708 ;;; Oboe family stencils
710 (define (oboe-lh-octave-key-stencil long?)
711 (let* ((h (if long? 1.4 1.2)))
712 (standard-path-stencil
713 `((-0.4 0 -0.4 1.0 -0.1 1.0)
721 (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f))
723 (define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f))
725 (define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t))
727 (define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8))
729 (define oboe-lh-d-key-stencil little-elliptical-key-stencil)
731 (define oboe-lh-cis-key-stencil little-elliptical-key-stencil)
733 (define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0))
735 (define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45))
737 (define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2))
739 (define oboe-rh-d-key-stencil little-elliptical-key-stencil)
741 (define oboe-rh-f-key-stencil little-elliptical-key-stencil)
743 (define (oboe-rh-c-rh-ees-key-stencil c?)
745 '((1.0 0.0 1.0 0.70 1.5 0.70)
746 (2.25 0.70 2.25 -0.4 1.5 -0.4)
751 (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0))))
753 (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil)
755 (define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t))
757 (define oboe-rh-cis-key-stencil
759 '((0.6 0.0 0.6 0.50 1.25 0.50)
760 (2.25 0.50 2.25 -0.4 1.25 -0.4)
761 (0.6 -0.4 0.6 0 0 0))
764 (lambda (stencil) (ly:stencil-rotate stencil 0 0 0))))
766 (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f))
768 ;;; Clarinet family stencils
770 (define clarinet-lh-thumb-key-stencil
771 (variable-column-circle-stencil 0.9))
773 (define clarinet-lh-R-key-stencil
774 (let* ((halfbase (cos (/ PI 10)))
777 (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
778 (standard-path-stencil
780 (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0)
781 (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height)
782 (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0))
786 (define (clarinet-lh-a-key-stencil radius thick fill layout props)
787 (let* ((width 0.4) (height 0.75) (linelen 0.45))
789 ((standard-e-stencil width height) radius thick fill layout props)
790 (ly:stencil-translate
791 (make-line-stencil thick 0 0 0 (* linelen radius))
792 (cons 0 (* height radius))))))
794 (define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
796 (define clarinet-lh-ees-key-stencil little-elliptical-key-stencil)
798 (define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil)
800 (define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil)
802 (define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil)
804 (define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil)
806 (define clarinet-lh-d-key-stencil (standard-e-stencil 1.0 0.4))
808 (define clarinet-rh-low-c-key-stencil
809 (standard-path-stencil
811 (0.0 2.5 -1.0 2.5 -1.0 0.75)
812 (-1.0 0.1 0.0 0.25 0.0 0.3)
817 (define clarinet-rh-low-cis-key-stencil
818 (standard-path-stencil
820 (0.0 1.67 -1.0 1.67 -1.0 0.92)
821 (-1.0 0.47 0.0 0.52 0.0 0.62)
826 (define clarinet-rh-low-d-key-stencil
827 (standard-path-stencil
829 (0.0 1.55 -1.0 1.55 -1.0 0.8)
830 (-1.0 0.35 0.0 0.4 0.0 0.5)
835 (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25))
837 (define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil)
839 (define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil)
841 (define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil)
843 (define clarinet-rh-b-key-stencil little-elliptical-key-stencil)
846 (define CL-RH-HAIR 0.09)
847 (define CL-RH-H-STRETCH 2.7)
848 (define CL-RH-V-STRETCH 0.9)
851 ; there is some unnecessary information duplication here.
852 ; need a way to control all of the below stencils so that if one
853 ; changes, all change...
855 (define clarinet-rh-fis-key-stencil
856 (standard-path-stencil
857 `(,(bezier-head-for-stencil
858 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
860 ,(bezier-head-for-stencil
861 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
863 (1.0 1.0 0.0 1.0 0.0 0.0))
867 (define clarinet-rh-gis-key-stencil
868 (standard-path-stencil
869 '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0))
873 (define clarinet-rh-e-key-stencil
874 (standard-path-stencil
875 `(,(bezier-head-for-stencil
876 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
878 ,(bezier-head-for-stencil
879 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
881 ,(bezier-head-for-stencil
882 `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5))
884 ,(bezier-head-for-stencil
885 `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75))
890 (define clarinet-rh-f-key-stencil clarinet-rh-gis-key-stencil)
892 (define bass-clarinet-rh-ees-key-stencil
893 (standard-path-stencil
894 `(,(bezier-head-for-stencil
895 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
897 ,(bezier-head-for-stencil
898 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
900 (1.0 1.0 0.0 1.0 0.0 0.0))
902 (- CL-RH-V-STRETCH)))
904 (define low-bass-clarinet-rh-ees-key-stencil clarinet-rh-e-key-stencil)
906 (define clarinet-rh-d-key-stencil clarinet-rh-gis-key-stencil)
908 ;;; Saxophone family stencils
910 (define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
912 (define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
914 (define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
916 (define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.7 0.7))
918 (define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5))
920 (define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75))
922 (define saxophone-lh-gis-key-stencil
923 (standard-path-stencil
925 (0.0 0.8 3.0 0.8 3.0 0.4)
927 (3.0 -0.4 0.0 -0.4 0.0 0.0))
931 (define (saxophone-lh-b-cis-key-stencil flip?)
932 (standard-path-stencil
934 (0.4 1.0 0.8 0.9 1.35 0.8)
937 (* (if flip? -1 1) 0.8)
940 (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t))
942 (define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f))
944 (define saxophone-lh-low-bes-key-stencil
945 (standard-path-stencil
946 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
950 (define (saxophone-rh-side-key-stencil width height)
951 (standard-path-stencil
953 (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15))
954 (,(- width 0.15) ,(+ height 0.15))
962 (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15)
964 (0.1 -0.1 0.05 -0.05 0.0 0.0))
968 (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2))
970 (define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.9 0.6))
972 (define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.9 0.45))
974 (define saxophone-rh-high-fis-key-stencil
975 (standard-path-stencil
977 '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
981 (coord-rotate x (atan (* -1 (/ PI 6)))))
984 ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
989 (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5))
991 (define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5))
993 (define saxophone-rh-low-c-key-stencil
994 (standard-path-stencil
995 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
999 (define (saxophone-lh-low-a-key-stencil radius thick fill layout props)
1003 (make-general-align-markup
1008 `(,(text-fill-translate fill))
1012 ;;; Bassoon family stencils
1014 (define (bassoon-bend-info-maker height gap cut)
1020 `((0.0 . ,(+ height gap))
1021 (0.0 . ,(+ height (+ gap 1.0)))
1022 (1.0 . ,(+ height (+ gap 2.0)))
1023 (2.0 . ,(+ height (+ gap 2.0))))
1031 (1.0 . ,(+ 0.5 height))
1032 (1.5 . ,(+ 1.0 height))
1033 (2.0 . ,(+ 1.0 height)))
1037 `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5))
1038 `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7))))
1041 `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1))
1042 `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3)))))
1043 (list first-bezier second-bezier slope-offset1 slope-offset2)))
1046 (make-tilted-portion
1054 `((,(+ keylen (list-ref first-bezier 6))
1058 (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1))))
1059 ((if bezier? (lambda (x) `(,(apply append x))) identity)
1060 `((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
1064 (+ (+ keylen 1.75) (list-ref first-bezier 6)))
1065 (cdr slope-offset1)))
1066 (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
1070 (+ (+ keylen 1.75) (list-ref second-bezier 0)))
1071 (cdr slope-offset2)))
1072 (,(+ keylen (list-ref second-bezier 0))
1074 (* (car slope-offset2) (+ keylen (list-ref second-bezier 0)))
1075 (cdr slope-offset2)))))
1076 `(,(list-head second-bezier 2))))
1078 (define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?)
1079 (let* ((info-list (bassoon-bend-info-maker height gap cut))
1080 (first-bezier (car info-list))
1081 (second-bezier (cadr info-list))
1082 (slope-offset1 (caddr info-list))
1083 (slope-offset2 (cadddr info-list)))
1086 `((0.0 ,(+ height gap))
1087 ,(list-tail first-bezier 2))
1088 (make-tilted-portion
1095 `(,(list-tail second-bezier 2)
1102 (define (bassoon-uber-key-stencil height gap cut keylen d1 d2)
1103 (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 identity #t))
1105 (define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8))
1107 (define bassoon-lh-he-key-stencil little-elliptical-key-stencil)
1109 (define bassoon-lh-hees-key-stencil little-elliptical-key-stencil)
1111 (define bassoon-lh-ees-key-stencil
1115 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1117 (define bassoon-lh-cis-key-stencil
1121 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1123 (define bassoon-lh-lbes-key-stencil
1124 (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6))
1126 (define bassoon-lh-lb-key-stencil
1127 (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6))
1129 (define bassoon-lh-lc-key-stencil
1130 (rich-pe-stencil 1.0 1.0 135 315 identity))
1132 (define bassoon-lh-ld-key-stencil
1133 (standard-path-stencil
1134 '((-0.8 4.0 1.4 4.0 0.6 0.0)
1135 (0.5 -0.5 0.5 -0.8 0.6 -1.0)
1136 (0.7 -1.2 0.8 -1.3 0.8 -1.8)
1138 (0.5 -1.4 0.4 -1.2 0.3 -1.1)
1139 (0.2 -1.0 0.1 -0.5 0.0 0.0))
1143 (define bassoon-lh-d-flick-key-stencil
1145 (standard-path-stencil
1147 (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8))
1148 (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0))
1149 (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3))
1150 (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1156 (define bassoon-lh-c-flick-key-stencil
1158 (standard-path-stencil
1160 (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8))
1161 (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0))
1162 (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3))
1163 (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1169 (define bassoon-lh-a-flick-key-stencil
1170 (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5))
1172 (define bassoon-lh-thumb-cis-key-stencil
1173 (bassoon-uber-key-stencil 1.5 1.5 0.6 0.6 -0.6 0.6))
1175 (define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7))
1177 (define bassoon-rh-cis-key-stencil
1178 (rich-bassoon-uber-key-stencil
1185 (lambda (stencil) (ly:stencil-rotate stencil -76 0 0))
1188 (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil)
1190 (define bassoon-rh-fis-key-stencil
1191 (rich-bassoon-uber-key-stencil 0.5 1.0 0.8 1.5 -0.7 0.7 identity #f))
1193 (define bassoon-rh-f-key-stencil
1194 (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5)
1195 (info-list (bassoon-bend-info-maker height gap cut))
1196 (first-bezier (car info-list))
1197 (second-bezier (cadr info-list))
1198 (slope-offset1 (caddr info-list))
1199 (slope-offset2 (cadddr info-list)))
1200 (standard-path-stencil
1207 (list-tail first-bezier 6)))
1208 (make-tilted-portion
1219 (define bassoon-rh-gis-key-stencil
1220 (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7))
1222 (define bassoon-rh-thumb-bes-key-stencil
1223 (bassoon-uber-key-stencil 1.0 1.0 0.9 1.0 0.7 0.7))
1225 (define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7))
1227 (define bassoon-rh-thumb-fis-key-stencil
1228 (bassoon-uber-key-stencil 1.0 1.2 0.9 1.0 0.7 0.7))
1230 (define bassoon-rh-thumb-gis-key-stencil
1231 (bassoon-uber-key-stencil 1.2 0.8 0.9 0.4 0.7 0.7))