1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2010--2011 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 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 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.
33 @code{guile> (function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
35 (if (null? function-list)
38 (apply (caar function-list) (append `(,arg) (cdar function-list)))
39 (cdr function-list))))
41 (define (rotunda-map function inlist rotunda)
42 "Like map, but with a rotating last argument to function.
44 @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))}
46 (define (rotunda-map-chain function inlist outlist rotunda)
52 (append outlist (list (function (car inlist) (car rotunda))))
53 (append (cdr rotunda) (list (car rotunda))))))
54 (rotunda-map-chain function inlist '() rotunda))
56 (define (assoc-keys alist)
57 "Gets the keys of an alist."
58 (map (lambda (x) (car x)) alist))
60 (define (assoc-values alist)
61 "Gets the values of an alist."
62 (map (lambda (x) (cdr x)) alist))
64 (define (get-slope-offset p1 p2)
65 "Gets the slope and offset for p1 and p2.
67 @code{(get-slope-offset '(1 . 2) '(3 . -5.1))}
68 @code{(-3.55 . 5.55)}"
70 ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2))))
71 (offset (- (cdr p1) (* slope (car p1)))))
74 (define (is-square? x input-list)
75 "Returns true if x is the square of a value in input-list."
76 (pair? (memv (inexact->exact (sqrt x)) input-list)))
78 (define (satisfies-function? function input-list)
79 "Returns true if an element in @code{input-list} is true
80 when @code{function} is applied to it.
82 @code{guile> (satisfies-function? null? '((1 2) ()))}
84 @code{guile> (satisfies-function? null? '((1 2) (3)))}
86 (if (null? input-list)
88 (or (function (car input-list))
89 (satisfies-function? function (cdr input-list)))))
91 (define (true-entry? input-list)
92 "Is there a true entry in @code{input-list}?"
93 (satisfies-function? identity input-list))
95 (define (entry-greater-than-x? input-list x)
96 "Is there an entry greater than @code{x} in @code{input-list}?"
97 (satisfies-function? (lambda (y) (> y x)) input-list))
99 (define (n-true-entries input-list)
100 "Returns number of true entries in @code{input-list}."
101 (reduce + 0 (map (lambda (x) (if x 1 0)) input-list)))
103 (define (bezier-head-for-stencil bezier cut-point)
104 "Prepares a split-bezier to be used in a connected path stencil."
105 (list-tail (flatten-list (car (split-bezier bezier cut-point))) 2))
107 ;; Translators for keys
109 ; Translates a "normal" key (open, closed, trill)
110 (define (key-fill-translate fill)
114 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
115 ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t)))
117 ; Similar to above, but trans vs opaque doesn't matter
118 (define (text-fill-translate fill)
121 ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
122 ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0)))
124 ; Emits a list for the central-column-hole maker
125 ; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?)
126 ; Multiple values, such as (#t #f #f #t #f), mean a trill between
127 ; not-full and 3-quarters-full
128 (define (process-fill-value fill)
129 (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1)))
130 (append `(,(or (< fill 3) (is-square? fill avals)))
131 (map (lambda (x) (= 0 (remainder fill x))) avals))))
133 ; Color a stencil gray
134 (define (gray-colorize stencil)
135 (apply ly:stencil-in-color (cons stencil (x11-color 'grey))))
137 ; A connected path stencil that is surrounded by proc
138 (define (rich-path-stencil ls x-stretch y-stretch proc)
139 (lambda (radius thick fill layout props)
141 ((fill-translate (key-fill-translate fill))
142 (gray? (eqv? fill-translate 0.5)))
144 ((if gray? gray-colorize identity)
146 (make-connected-path-stencil
152 (if gray? #t fill-translate))))
155 ((rich-path-stencil ls x-stretch y-stretch proc)
162 ; A connected path stencil without a surrounding proc
163 (define (standard-path-stencil ls x-stretch y-stretch)
164 (rich-path-stencil ls x-stretch y-stretch identity))
166 ; An ellipse stencil that is surrounded by a proc
167 (define (rich-pe-stencil x-stretch y-stretch start end proc)
168 (lambda (radius thick fill layout props)
170 ((fill-translate (key-fill-translate fill))
171 (gray? (eqv? fill-translate 0.5)))
173 ((if gray? gray-colorize identity)
175 (make-partial-ellipse-stencil
182 (if gray? #t fill-translate))))
185 ((rich-pe-stencil x-stretch y-stretch start end proc)
192 (define (rich-e-stencil x-stretch y-stretch proc)
193 (lambda (radius thick fill layout props)
195 ((fill-translate (key-fill-translate fill))
196 (gray? (eqv? fill-translate 0.5)))
198 ((if gray? gray-colorize identity)
200 (make-ellipse-stencil
204 (if gray? #t fill-translate))))
207 ((rich-e-stencil x-stretch y-stretch proc)
214 ; An ellipse stencil without a surrounding proc
215 (define (standard-e-stencil x-stretch y-stretch)
216 (rich-e-stencil x-stretch y-stretch identity))
218 ; Translates all possible representations of symbol.
219 ; If simple? then the only representations are open, closed, and trill.
220 ; Otherwise, there can be various levels of "closure" on the holes
221 ; ring? allows for a ring around the holes as well
222 (define (make-symbol-alist symbol simple? ring?)
227 `(,(symbol-concatenate symbol 'T 'F) .
228 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))))
230 `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
231 (,(symbol-concatenate symbol 'T) .
232 ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))
238 `((,(symbol-concatenate symbol (car x) 'T)
240 (,(symbol-concatenate symbol 'T (car x))
241 . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
242 (,(symbol-concatenate symbol (car x))
247 `(,(symbol-concatenate symbol
251 . ,(* (cdr a) (cdr b))))
253 (cdr (member x HOLE-FILL-LIST))))))
254 (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST))))))))
256 ;;; Commands for text layout
258 ; Draws a circle around markup if (= trigger 0.5)
259 (define-markup-command
260 (conditional-circle-markup layout props trigger in-markup)
262 (interpret-markup layout props
263 (if (eqv? trigger 0.5)
264 (markup #:circle (markup in-markup))
265 (markup in-markup))))
267 ; Makes a list of named-keys
268 (define (make-name-keylist input-list key-list font-size)
271 (markup #:conditional-circle-markup
275 (markup #:abs-fontsize font-size (car y))
276 (if (and (< x 1) (cdr y))
296 input-list key-list))
298 ; Makes a list of number-keys
299 (define (make-number-keylist input-list key-list font-size)
303 #:conditional-circle-markup
305 (markup #:abs-fontsize font-size #:number y))
310 ; Creates a named-key list with a certain alignment
311 (define (aligned-text-stencil-function dir hv)
312 (lambda (key-name-list radius fill-list layout props)
316 (make-general-align-markup
319 ((if hv make-concat-markup make-center-column-markup)
321 (map text-fill-translate fill-list)
325 (define number-column-stencil
326 (lambda (key-name-list radius fill-list layout props)
330 (make-general-align-markup
333 (make-general-align-markup
336 (make-override-markup
340 (map text-fill-translate fill-list)
344 ; Utility function for the left-hand keys
345 (define lh-woodwind-text-stencil
346 (aligned-text-stencil-function LEFT #t))
348 ; Utility function for the right-hand keys
349 (define rh-woodwind-text-stencil
350 (aligned-text-stencil-function RIGHT #t))
352 (define octave-woodwind-text-stencil
353 (aligned-text-stencil-function CENTER #f))
357 (define (rich-group-draw-rule alist target-part change-part)
359 (entry-greater-than-x?
360 (map (lambda (key) (assoc-get key alist)) target-part) 3)
361 (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist)
364 (define (bassoon-midline-rule alist target-part)
366 (entry-greater-than-x?
367 (map (lambda (key) (assoc-get key alist)) target-part) 0)
368 (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist)
369 (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist)))
371 (define (group-draw-rule alist target-part)
372 (rich-group-draw-rule alist target-part target-part))
374 (define (group-automate-rule alist change-part)
375 (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist))
377 (define (apply-group-draw-rule-series alist target-part-list)
378 (if (null? target-part-list)
380 (apply-group-draw-rule-series
381 (group-draw-rule alist (car target-part-list))
382 (cdr target-part-list))))
384 ;; Extra-offset rules
386 (define (rich-group-extra-offset-rule alist target-part change-part eos)
388 (entry-greater-than-x?
389 (map (lambda (key) (assoc-get key alist)) target-part) 0)
390 (map-selected-alist-keys (lambda (x) eos) change-part alist)
393 (define (group-extra-offset-rule alist target-part eos)
394 (rich-group-extra-offset-rule alist target-part target-part eos))
396 (define (uniform-extra-offset-rule alist eos)
397 (map-selected-alist-keys
398 (lambda (x) (if (pair? x) x eos))
402 ;;; General drawing commands
404 ; Used all the time for a dividing line
405 (define (midline-stencil radius thick fill layout props)
406 (make-line-stencil (* thick 2) (* -0.80 radius) 0 (* 0.80 radius) 0))
408 (define (long-midline-stencil radius thick fill layout props)
409 (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0))
411 ; Used all the time for a small, between-hole key
412 (define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2))
414 ; Used for several upper keys in the clarinet and sax
415 (define (upper-key-stencil tailw tailh bodyw bodyh)
417 ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2))))))
418 (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05)))))))
419 (standard-path-stencil
435 ,(- -0.025 (/ tailh 2))
441 ; Utility function for the column-hole maker.
442 ; Returns the left and right degrees for the drawing of a given
443 ; fill level (1-quarter, 1-half, etc...)
444 (define (degree-first-true fill-list left? reverse?)
445 (define (dfl-crawler fill-list os-list left?)
447 ((if left? car cdr) (car os-list))
448 (dfl-crawler (cdr fill-list) (cdr os-list) left?)))
450 ((if reverse? reverse identity) fill-list)
451 ((if reverse? reverse identity)
452 '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90)))
455 ; Gets the position of the first (or last if reverse?) element of a list.
456 (define (position-true-endpoint in-list reverse?)
457 (define (pte-crawler in-list n)
460 (pte-crawler (cdr in-list) (+ n 1))))
462 (if reverse? (length in-list) 0)
463 (pte-crawler ((if reverse? reverse identity) in-list) 0)))
465 ; Huge, kind-of-ugly maker of a circle in a column.
466 ; I think this is the clearest way to write it, though...
468 (define (column-circle-stencil radius thick fill layout props)
469 (let* ((fill-list (process-fill-value fill)))
472 (list-ref fill-list 0)
473 (not (true-entry? (list-tail fill-list 1)))) ; is it empty?
474 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
476 (list-ref fill-list 4)
477 (not (true-entry? (list-head fill-list 4)))) ; is it full?
478 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
480 (list-ref fill-list 0)
481 (list-ref fill-list 4)) ; is it a trill between empty and full?
482 ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
483 (else ;If none of these, it is partially full.
485 ((rich-pe-stencil 1.0 1.0 0 360 identity)
488 (if (list-ref fill-list 4)
489 (expt (assoc-get 'F HOLE-FILL-LIST) 2)
496 (degree-first-true fill-list #t #t)
497 (degree-first-true fill-list #f #t)
503 (list-head fill-list (position-true-endpoint fill-list #t)))
504 (expt (assoc-get 'F HOLE-FILL-LIST) 2)
505 (assoc-get 'F HOLE-FILL-LIST))
509 (= 2 (n-true-entries (list-tail fill-list 1))) ; trill?
513 (degree-first-true fill-list #t #f)
514 (degree-first-true fill-list #f #f)
518 (assoc-get 'F HOLE-FILL-LIST)
523 (define (variable-column-circle-stencil scaler)
524 (lambda (radius thick fill layout props)
525 (column-circle-stencil (* radius scaler) thick fill layout props)))
527 ; A stencil for ring-column circles that combines two of the above
528 (define (ring-column-circle-stencil radius thick fill layout props)
529 (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST)))
532 (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
536 (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))
537 (* (+ (- 1.0 (* 2 thick)) (/ thick 2))))
539 (* (* 4 radius) thick)
543 ((standard-e-stencil 1.0 1.0) radius thick 1 layout props)
544 (column-circle-stencil
545 (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2))
548 (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST)))
549 (assoc-get 'F HOLE-FILL-LIST)
551 (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
552 (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
553 (/ fill (assoc-get 'R HOLE-FILL-LIST))))
556 (column-circle-stencil radius thick fill layout props)))
558 ;;; Flute family stencils
560 (define flute-lh-b-key-stencil
561 (standard-path-stencil
563 (0 1.625 -0.125 1.75 -0.25 1.75)
564 (-0.55 1.75 -0.55 0.95 -0.25 0.7)
569 (define flute-lh-bes-key-stencil
570 (standard-path-stencil
572 (0 1.625 -0.125 1.75 -0.25 1.75)
573 (-0.55 1.75 -0.55 0.95 -0.25 0.7)
578 (define (flute-lh-gis-rh-bes-key-stencil deg)
580 '((0.1 0.1 0.2 0.4 0.3 0.6)
581 (0.3 1.0 0.8 1.0 0.8 0.7)
582 (0.8 0.3 0.5 0.3 0 0))
585 (lambda (stencil) (ly:stencil-rotate stencil deg 0 0))))
587 (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0))
589 (define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200))
591 (define flute-rh-d-key-stencil little-elliptical-key-stencil)
593 (define flute-rh-dis-key-stencil little-elliptical-key-stencil)
595 (define flute-rh-ees-key-stencil
596 (standard-path-stencil
597 '((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))
601 (define (piccolo-rh-x-key-stencil radius thick fill layout props)
605 (make-general-align-markup
610 `(,(text-fill-translate fill))
614 (define flute-lower-row-stretch 1.4)
616 (define flute-rh-cis-key-stencil
617 (standard-path-stencil
618 '((0 0.75) (-0.8 0.75 -0.8 0 0 0))
619 flute-lower-row-stretch
620 flute-lower-row-stretch))
622 (define flute-rh-c-key-stencil
623 (standard-path-stencil
624 '((0 0.75) (0.4 0.75) (0.4 0) (0 0))
625 flute-lower-row-stretch
626 flute-lower-row-stretch))
628 (define flute-rh-b-key-stencil
629 (standard-path-stencil
630 '((0 0.75) (0.25 0.75) (0.25 0) (0 0))
631 flute-lower-row-stretch
632 flute-lower-row-stretch))
634 (define flute-rh-gz-key-stencil
636 '((0.1 0.1 0.4 0.2 0.6 0.3)
637 (1.0 0.3 1.0 0.8 0.7 0.8)
638 (0.3 0.8 0.3 0.5 0 0))
639 flute-lower-row-stretch
640 flute-lower-row-stretch
641 (lambda (stencil) (ly:stencil-rotate stencil 160 0 0))))
643 ;;; Shared oboe/clarinet stencils
645 (define (oboe-lh-gis-lh-low-b-key-stencil gis?)
653 `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0))
658 `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
661 (standard-path-stencil
664 `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0))
669 (coord-rotate x (atan (/ y (* 2 0.25))))
672 `(((0 . ,y) (,x . ,y) (,x . 0))
673 ((,x . ,(- y)) (0 . ,(- y)) (0 . 0)))))
674 `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0)))
677 (standard-path-stencil
681 (coord-rotate x (atan (/ y (* 2 0.25)))))
683 `(,(list-tail up-part 1)
684 ,(list-head down-part 1)
685 ,(list-tail down-part 1)))
687 (- scaling-factor)))))
689 (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t))
691 (define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f))
693 (define (oboe-lh-ees-lh-bes-key-stencil ees?)
694 (standard-path-stencil
696 (0 1.625 -0.125 1.75 -0.25 1.75)
697 (-0.5 1.75 -0.5 0.816 -0.25 0.5)
699 (0 ,(if ees? -0.6 -0.3)))
700 (* (if ees? -1.0 1.0) -1.8)
703 (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t))
705 (define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f))
707 ;;; Oboe family stencils
709 (define (oboe-lh-octave-key-stencil long?)
710 (let* ((h (if long? 1.4 1.2)))
711 (standard-path-stencil
712 `((-0.4 0 -0.4 1.0 -0.1 1.0)
720 (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f))
722 (define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f))
724 (define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t))
726 (define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8))
728 (define oboe-lh-d-key-stencil little-elliptical-key-stencil)
730 (define oboe-lh-cis-key-stencil little-elliptical-key-stencil)
732 (define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0))
734 (define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45))
736 (define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2))
738 (define oboe-rh-d-key-stencil little-elliptical-key-stencil)
740 (define oboe-rh-f-key-stencil little-elliptical-key-stencil)
742 (define (oboe-rh-c-rh-ees-key-stencil c?)
744 '((1.0 0.0 1.0 0.70 1.5 0.70)
745 (2.25 0.70 2.25 -0.4 1.5 -0.4)
750 (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0))))
752 (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil)
754 (define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t))
756 (define oboe-rh-cis-key-stencil
758 '((0.6 0.0 0.6 0.50 1.25 0.50)
759 (2.25 0.50 2.25 -0.4 1.25 -0.4)
760 (0.6 -0.4 0.6 0 0 0))
763 (lambda (stencil) (ly:stencil-rotate stencil 0 0 0))))
765 (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f))
767 ;;; Clarinet family stencils
769 (define clarinet-lh-thumb-key-stencil
770 (variable-column-circle-stencil 0.9))
772 (define clarinet-lh-R-key-stencil
773 (let* ((halfbase (cos (/ PI 10)))
776 (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
777 (standard-path-stencil
779 (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0)
780 (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height)
781 (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0))
785 (define (clarinet-lh-a-key-stencil radius thick fill layout props)
786 (let* ((width 0.4) (height 0.75) (linelen 0.45))
788 ((standard-e-stencil width height) radius thick fill layout props)
789 (ly:stencil-translate
790 (make-line-stencil thick 0 0 0 (* linelen radius))
791 (cons 0 (* height radius))))))
793 (define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
795 (define clarinet-lh-ees-key-stencil little-elliptical-key-stencil)
797 (define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil)
799 (define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil)
801 (define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil)
803 (define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil)
805 (define clarinet-lh-d-key-stencil (standard-e-stencil 1.0 0.4))
807 (define clarinet-rh-low-c-key-stencil
808 (standard-path-stencil
810 (0.0 2.5 -1.0 2.5 -1.0 0.75)
811 (-1.0 0.1 0.0 0.25 0.0 0.3)
816 (define clarinet-rh-low-cis-key-stencil
817 (standard-path-stencil
819 (0.0 1.67 -1.0 1.67 -1.0 0.92)
820 (-1.0 0.47 0.0 0.52 0.0 0.62)
825 (define clarinet-rh-low-d-key-stencil
826 (standard-path-stencil
828 (0.0 1.55 -1.0 1.55 -1.0 0.8)
829 (-1.0 0.35 0.0 0.4 0.0 0.5)
834 (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25))
836 (define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil)
838 (define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil)
840 (define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil)
842 (define clarinet-rh-b-key-stencil little-elliptical-key-stencil)
845 (define CL-RH-HAIR 0.09)
846 (define CL-RH-H-STRETCH 2.7)
847 (define CL-RH-V-STRETCH 0.9)
850 ; there is some unnecessary information duplication here.
851 ; need a way to control all of the below stencils so that if one
852 ; changes, all change...
854 (define clarinet-rh-fis-key-stencil
855 (standard-path-stencil
856 `(,(bezier-head-for-stencil
857 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
859 ,(bezier-head-for-stencil
860 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
862 (1.0 1.0 0.0 1.0 0.0 0.0))
866 (define clarinet-rh-e-key-stencil
867 (standard-path-stencil
868 '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0))
872 (define clarinet-rh-ees-key-stencil
873 (standard-path-stencil
874 `(,(bezier-head-for-stencil
875 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
877 ,(bezier-head-for-stencil
878 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
880 ,(bezier-head-for-stencil
881 `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5))
883 ,(bezier-head-for-stencil
884 `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75))
889 (define clarinet-rh-gis-key-stencil clarinet-rh-e-key-stencil)
891 (define bass-clarinet-rh-f-key-stencil
892 (standard-path-stencil
893 `(,(bezier-head-for-stencil
894 '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
896 ,(bezier-head-for-stencil
897 '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
899 (1.0 1.0 0.0 1.0 0.0 0.0))
901 (- CL-RH-V-STRETCH)))
903 (define low-bass-clarinet-rh-f-key-stencil clarinet-rh-ees-key-stencil)
905 (define clarinet-rh-d-key-stencil clarinet-rh-e-key-stencil)
907 ;;; Saxophone family stencils
909 (define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
911 (define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
913 (define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
915 (define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.7 0.7))
917 (define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5))
919 (define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75))
921 (define saxophone-lh-gis-key-stencil
922 (standard-path-stencil
924 (0.0 0.8 3.0 0.8 3.0 0.4)
926 (3.0 -0.4 0.0 -0.4 0.0 0.0))
930 (define (saxophone-lh-b-cis-key-stencil flip?)
931 (standard-path-stencil
933 (0.4 1.0 0.8 0.9 1.35 0.8)
936 (* (if flip? -1 1) 0.8)
939 (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t))
941 (define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f))
943 (define saxophone-lh-low-bes-key-stencil
944 (standard-path-stencil
945 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
949 (define (saxophone-rh-side-key-stencil width height)
950 (standard-path-stencil
952 (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15))
953 (,(- width 0.15) ,(+ height 0.15))
961 (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15)
963 (0.1 -0.1 0.05 -0.05 0.0 0.0))
967 (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2))
969 (define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.9 0.6))
971 (define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.9 0.45))
973 (define saxophone-rh-high-fis-key-stencil
974 (standard-path-stencil
976 '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
980 (coord-rotate x (atan (* -1 (/ PI 6)))))
983 ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
988 (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5))
990 (define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5))
992 (define saxophone-rh-low-c-key-stencil
993 (standard-path-stencil
994 '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
998 (define (saxophone-lh-low-a-key-stencil radius thick fill layout props)
1002 (make-general-align-markup
1007 `(,(text-fill-translate fill))
1011 ;;; Bassoon family stencils
1013 (define (bassoon-bend-info-maker height gap cut)
1019 `((0.0 . ,(+ height gap))
1020 (0.0 . ,(+ height (+ gap 1.0)))
1021 (1.0 . ,(+ height (+ gap 2.0)))
1022 (2.0 . ,(+ height (+ gap 2.0))))
1030 (1.0 . ,(+ 0.5 height))
1031 (1.5 . ,(+ 1.0 height))
1032 (2.0 . ,(+ 1.0 height)))
1036 `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5))
1037 `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7))))
1040 `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1))
1041 `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3)))))
1042 (list first-bezier second-bezier slope-offset1 slope-offset2)))
1045 (make-tilted-portion
1053 `((,(+ keylen (list-ref first-bezier 6))
1057 (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1))))
1058 ((if bezier? (lambda (x) `(,(apply append x))) identity)
1059 `((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
1063 (+ (+ keylen 1.75) (list-ref first-bezier 6)))
1064 (cdr slope-offset1)))
1065 (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
1069 (+ (+ keylen 1.75) (list-ref second-bezier 0)))
1070 (cdr slope-offset2)))
1071 (,(+ keylen (list-ref second-bezier 0))
1073 (* (car slope-offset2) (+ keylen (list-ref second-bezier 0)))
1074 (cdr slope-offset2)))))
1075 `(,(list-head second-bezier 2))))
1077 (define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?)
1078 (let* ((info-list (bassoon-bend-info-maker height gap cut))
1079 (first-bezier (car info-list))
1080 (second-bezier (cadr info-list))
1081 (slope-offset1 (caddr info-list))
1082 (slope-offset2 (cadddr info-list)))
1085 `((0.0 ,(+ height gap))
1086 ,(list-tail first-bezier 2))
1087 (make-tilted-portion
1094 `(,(list-tail second-bezier 2)
1101 (define (bassoon-uber-key-stencil height gap cut keylen d1 d2)
1102 (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 identity #t))
1104 (define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8))
1106 (define bassoon-lh-he-key-stencil little-elliptical-key-stencil)
1108 (define bassoon-lh-hees-key-stencil little-elliptical-key-stencil)
1110 (define bassoon-lh-ees-key-stencil
1114 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1116 (define bassoon-lh-cis-key-stencil
1120 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1122 (define bassoon-lh-lbes-key-stencil
1123 (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6))
1125 (define bassoon-lh-lb-key-stencil
1126 (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6))
1128 (define bassoon-lh-lc-key-stencil
1129 (rich-pe-stencil 1.0 1.0 135 315 identity))
1131 (define bassoon-lh-ld-key-stencil
1132 (standard-path-stencil
1133 '((-0.8 4.0 1.4 4.0 0.6 0.0)
1134 (0.5 -0.5 0.5 -0.8 0.6 -1.0)
1135 (0.7 -1.2 0.8 -1.3 0.8 -1.8)
1137 (0.5 -1.4 0.4 -1.2 0.3 -1.1)
1138 (0.2 -1.0 0.1 -0.5 0.0 0.0))
1142 (define bassoon-lh-d-flick-key-stencil
1144 (standard-path-stencil
1146 (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8))
1147 (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0))
1148 (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3))
1149 (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1155 (define bassoon-lh-c-flick-key-stencil
1157 (standard-path-stencil
1159 (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8))
1160 (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0))
1161 (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3))
1162 (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1168 (define bassoon-lh-a-flick-key-stencil
1169 (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5))
1171 (define bassoon-lh-thumb-cis-key-stencil
1172 (bassoon-uber-key-stencil 1.5 1.5 0.6 0.6 -0.6 0.6))
1174 (define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7))
1176 (define bassoon-rh-cis-key-stencil
1177 (rich-bassoon-uber-key-stencil
1184 (lambda (stencil) (ly:stencil-rotate stencil -76 0 0))
1187 (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil)
1189 (define bassoon-rh-fis-key-stencil
1190 (rich-bassoon-uber-key-stencil 0.5 1.0 0.8 1.5 -0.7 0.7 identity #f))
1192 (define bassoon-rh-f-key-stencil
1193 (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5)
1194 (info-list (bassoon-bend-info-maker height gap cut))
1195 (first-bezier (car info-list))
1196 (second-bezier (cadr info-list))
1197 (slope-offset1 (caddr info-list))
1198 (slope-offset2 (cadddr info-list)))
1199 (standard-path-stencil
1206 (list-tail first-bezier 6)))
1207 (make-tilted-portion
1218 (define bassoon-rh-gis-key-stencil
1219 (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7))
1221 (define bassoon-rh-thumb-bes-key-stencil
1222 (bassoon-uber-key-stencil 1.0 1.0 0.9 1.0 0.7 0.7))
1224 (define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7))
1226 (define bassoon-rh-thumb-fis-key-stencil
1227 (bassoon-uber-key-stencil 1.0 1.2 0.9 1.0 0.7 0.7))
1229 (define bassoon-rh-thumb-gis-key-stencil
1230 (bassoon-uber-key-stencil 1.2 0.8 0.9 0.4 0.7 0.7))