scm/define-woodwind-diagrams.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   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>
   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 @code{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 @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}.
  33
  34 Example: Executing @samp{(function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
  35 returns @samp{1/3}."
  36   (if (null? function-list)
  37     arg
  38     (function-chain
  39       (apply (caar function-list) (append `(,arg) (cdar function-list)))
  40       (cdr function-list))))
  41
  42 (define (rotunda-map function inlist rotunda)
  43   "Like map, but with a rotating last argument to function.
  44    For example:
  45    @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))}
  46    @code{(2 -8 4 -6)}"
  47   (define (rotunda-map-chain function inlist outlist rotunda)
  48     (if (null? inlist)
  49       outlist
  50      (rotunda-map-chain
  51        function
  52        (cdr inlist)
  53        (append outlist (list (function (car inlist) (car rotunda))))
  54        (append (cdr rotunda) (list (car rotunda))))))
  55   (rotunda-map-chain function inlist '() rotunda))
  56
  57 (define (assoc-keys alist)
  58   "Gets the keys of an alist."
  59   (map (lambda (x) (car x)) alist))
  60
  61 (define (assoc-values alist)
  62   "Gets the values of an alist."
  63   (map (lambda (x) (cdr x)) alist))
  64
  65 (define (get-slope-offset p1 p2)
  66   "Gets the slope and offset for p1 and p2.
  67    For example:
  68    @code{(get-slope-offset '(1 . 2) '(3 . -5.1))}
  69    @code{(-3.55 . 5.55)}"
  70   (let*
  71     ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2))))
  72     (offset (- (cdr p1) (* slope (car p1)))))
  73    `(,slope . ,offset)))
  74
  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)))
  78
  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.
  82    For example:
  83    @code{guile> (satisfies-function? null? '((1 2) ()))}
  84    @code{#t}
  85    @code{guile> (satisfies-function? null? '((1 2) (3)))}
  86    @code{#f}"
  87   (if (null?  input-list)
  88     #f
  89     (or (function (car input-list))
  90       (satisfies-function? function (cdr input-list)))))
  91
  92 (define (true-entry? input-list)
  93   "Is there a true entry in @code{input-list}?"
  94   (satisfies-function? identity input-list))
  95
  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))
  99
 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)))
 103
 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))
 107
 108 ;; Translators for keys
 109
 110 ; Translates a "normal" key (open, closed, trill)
 111 (define (key-fill-translate fill)
 112   (cond
 113     ((= fill 1) #f)
 114     ((= fill 2) #f)
 115     ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
 116     ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t)))
 117
 118 ; Similar to above, but trans vs opaque doesn't matter
 119 (define (text-fill-translate fill)
 120   (cond
 121     ((< fill 3) 1.0)
 122     ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
 123     ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0)))
 124
 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))))
 133
 134 ; Color a stencil gray
 135 (define (gray-colorize stencil)
 136   (apply ly:stencil-in-color (cons stencil (x11-color 'grey))))
 137
 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)
 141     (let*
 142       ((fill-translate (key-fill-translate fill))
 143        (gray? (eqv? fill-translate 0.5)))
 144      (ly:stencil-add
 145       ((if gray? gray-colorize identity)
 146       (proc
 147         (make-connected-path-stencil
 148         ls
 149         thick
 150         (* x-stretch radius)
 151         (* y-stretch radius)
 152         #f
 153         (if gray? #t fill-translate))))
 154       (if (not gray?)
 155           empty-stencil
 156           ((rich-path-stencil ls x-stretch y-stretch proc)
 157            radius
 158            thick
 159            1
 160            layout
 161            props))))))
 162
 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))
 166
 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)
 170     (let*
 171       ((fill-translate (key-fill-translate fill))
 172        (gray? (eqv? fill-translate 0.5)))
 173      (ly:stencil-add
 174       ((if gray? gray-colorize identity)
 175       (proc
 176         (make-partial-ellipse-stencil
 177         (* x-stretch radius)
 178         (* y-stretch radius)
 179         start
 180         end
 181         thick
 182         #t
 183         (if gray? #t fill-translate))))
 184       (if (not gray?)
 185           empty-stencil
 186           ((rich-pe-stencil x-stretch y-stretch start end proc)
 187            radius
 188            thick
 189            1
 190            layout
 191            props))))))
 192
 193 (define (rich-e-stencil x-stretch y-stretch proc)
 194   (lambda (radius thick fill layout props)
 195     (let*
 196       ((fill-translate (key-fill-translate fill))
 197        (gray? (eqv? fill-translate 0.5)))
 198      (ly:stencil-add
 199       ((if gray? gray-colorize identity)
 200       (proc
 201         (make-ellipse-stencil
 202           (* x-stretch radius)
 203           (* y-stretch radius)
 204           thick
 205           (if gray? #t fill-translate))))
 206       (if (not gray?)
 207         empty-stencil
 208         ((rich-e-stencil x-stretch y-stretch proc)
 209           radius
 210           thick
 211           1
 212           layout
 213           props))))))
 214
 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))
 218
 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?)
 224   (filter (lambda (x)
 225             (not
 226               (equal?
 227                 x
 228                 `(,(symbol-concatenate symbol 'T 'F) .
 229                  ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))))
 230           (append
 231             `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
 232               (,(symbol-concatenate symbol 'T) .
 233                ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))
 234             (if simple?
 235                 '()
 236                 (apply append
 237                   (map (lambda (x)
 238                          (append
 239                            `((,(symbol-concatenate symbol (car x) 'T)
 240                               . ,(expt (cdr x) 2))
 241                              (,(symbol-concatenate symbol 'T (car x))
 242                               . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
 243                              (,(symbol-concatenate symbol (car x))
 244                               . ,(cdr x)))
 245                              (apply append
 246                                (map (lambda (y)
 247                                       (map (lambda (a b)
 248                                              `(,(symbol-concatenate symbol
 249                                                                     (car a)
 250                                                                     'T
 251                                                                     (car b))
 252                                                . ,(* (cdr a) (cdr b))))
 253                                            `(,x ,y) `(,y ,x)))
 254                                     (cdr (member x HOLE-FILL-LIST))))))
 255                        (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST))))))))
 256
 257 ;;; Commands for text layout
 258
 259 ; Draws a circle around markup if (= trigger 0.5)
 260 (define-markup-command
 261   (conditional-circle-markup layout props trigger in-markup)
 262   (number? markup?)
 263   (interpret-markup layout props
 264     (if (eqv? trigger 0.5)
 265       (markup #:circle (markup in-markup))
 266       (markup in-markup))))
 267
 268 ; Makes a list of named-keys
 269 (define (make-name-keylist input-list key-list font-size)
 270   (map (lambda (x y)
 271          (if (< x 1)
 272            (markup #:conditional-circle-markup
 273              x
 274              (make-concat-markup
 275                (list
 276                  (markup #:abs-fontsize font-size (car y))
 277                  (if (and (< x 1) (cdr y))
 278                    (if (eqv? (cdr y) 1)
 279                      (markup
 280                        #:abs-fontsize
 281                        font-size
 282                        #:raise
 283                        1
 284                        #:fontsize
 285                        -2
 286                        #:sharp)
 287                      (markup
 288                        #:abs-fontsize
 289                        font-size
 290                        #:raise
 291                        1
 292                        #:fontsize
 293                        -2
 294                        #:flat))
 295                  (markup #:null)))))
 296            (markup #:null)))
 297          input-list key-list))
 298
 299 ; Makes a list of number-keys
 300 (define (make-number-keylist input-list key-list font-size)
 301   (map (lambda (x y)
 302          (if (< x 1)
 303            (markup
 304              #:conditional-circle-markup
 305              x
 306              (markup #:abs-fontsize font-size #:number y))
 307            (markup #:null)))
 308        input-list
 309        key-list))
 310
 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)
 314     (interpret-markup
 315       layout
 316       props
 317       (make-general-align-markup
 318         X
 319         dir
 320         ((if hv make-concat-markup make-center-column-markup)
 321           (make-name-keylist
 322             (map text-fill-translate fill-list)
 323             key-name-list
 324             (* 12 radius)))))))
 325
 326 (define number-column-stencil
 327   (lambda (key-name-list radius fill-list layout props)
 328     (interpret-markup
 329       layout
 330       props
 331       (make-general-align-markup
 332         Y
 333         CENTER
 334         (make-general-align-markup
 335           X
 336           RIGHT
 337           (make-override-markup
 338             '(baseline-skip . 0)
 339             (make-column-markup
 340               (make-number-keylist
 341                 (map text-fill-translate fill-list)
 342                 key-name-list
 343                 (* radius 8)))))))))
 344
 345 ; Utility function for the left-hand keys
 346 (define lh-woodwind-text-stencil
 347   (aligned-text-stencil-function LEFT #t))
 348
 349 ; Utility function for the right-hand keys
 350 (define rh-woodwind-text-stencil
 351   (aligned-text-stencil-function RIGHT #t))
 352
 353 (define octave-woodwind-text-stencil
 354   (aligned-text-stencil-function CENTER #f))
 355
 356 ;;; Draw rules
 357
 358 (define (rich-group-draw-rule alist target-part change-part)
 359   (if
 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)
 363     alist))
 364
 365 (define (bassoon-midline-rule alist target-part)
 366   (if
 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)))
 371
 372 (define (group-draw-rule alist target-part)
 373   (rich-group-draw-rule alist target-part target-part))
 374
 375 (define (group-automate-rule alist change-part)
 376   (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist))
 377
 378 (define (apply-group-draw-rule-series alist target-part-list)
 379   (if (null? target-part-list)
 380     alist
 381     (apply-group-draw-rule-series
 382       (group-draw-rule alist (car target-part-list))
 383       (cdr target-part-list))))
 384
 385 ;; Extra-offset rules
 386
 387 (define (rich-group-extra-offset-rule alist target-part change-part eos)
 388   (if
 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)
 392     alist))
 393
 394 (define (group-extra-offset-rule alist target-part eos)
 395   (rich-group-extra-offset-rule alist target-part target-part eos))
 396
 397 (define (uniform-extra-offset-rule alist eos)
 398   (map-selected-alist-keys
 399     (lambda (x) (if (pair? x) x eos))
 400     (assoc-keys alist)
 401     alist))
 402
 403 ;;; General drawing commands
 404
 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))
 408
 409 (define (long-midline-stencil radius thick fill layout props)
 410   (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0))
 411
 412 ; Used all the time for a small, between-hole key
 413 (define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2))
 414
 415 ; Used for several upper keys in the clarinet and sax
 416 (define (upper-key-stencil tailw tailh bodyw bodyh)
 417   (let*
 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
 421     `((,(xmove 0.7)
 422        ,(ymove -0.2)
 423        ,(xmove 1.0)
 424        ,(ymove -1.0)
 425        ,(xmove 0.5)
 426        ,(ymove -1.0))
 427       (,(xmove 0.2)
 428        ,(ymove -1.0)
 429        ,(xmove 0.2)
 430        ,(ymove -0.2)
 431        ,(xmove 0.3)
 432        ,(ymove -0.1))
 433       (,(+ 0.2 tailw)
 434        ,(- -0.05 tailh)
 435        ,(+ 0.1 (/ tailw 2))
 436        ,(- -0.025 (/ tailh 2))
 437        0.0
 438        0.0))
 439     1.0
 440     1.0)))
 441
 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?)
 447     (if (car fill-list)
 448       ((if left? car cdr) (car os-list))
 449       (dfl-crawler (cdr fill-list) (cdr os-list) left?)))
 450   (dfl-crawler
 451     ((if reverse? reverse identity) fill-list)
 452     ((if reverse? reverse identity)
 453       '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90)))
 454     left?))
 455
 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)
 459     (if (car in-list)
 460       n
 461       (pte-crawler (cdr in-list) (+ n 1))))
 462   ((if reverse? - +)
 463     (if reverse? (length in-list) 0)
 464     (pte-crawler ((if reverse? reverse identity) in-list) 0)))
 465
 466 ; Huge, kind-of-ugly maker of a circle in a column.
 467 ; I think this is the clearest way to write it, though...
 468
 469 (define (column-circle-stencil radius thick fill layout props)
 470   (let* ((fill-list (process-fill-value fill)))
 471     (cond
 472       ((and
 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))
 476       ((and
 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))
 480       ((and
 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.
 485         (ly:stencil-add
 486           ((rich-pe-stencil 1.0 1.0 0 360 identity)
 487             radius
 488             thick
 489             (if (list-ref fill-list 4)
 490               (expt (assoc-get 'F HOLE-FILL-LIST) 2)
 491               1)
 492             layout
 493             props)
 494           ((rich-pe-stencil
 495             1.0
 496             1.0
 497             (degree-first-true fill-list #t #t)
 498             (degree-first-true fill-list #f #t)
 499             identity)
 500             radius
 501             thick
 502             (if
 503               (true-entry?
 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))
 507             layout
 508             props)
 509           (if
 510             (= 2 (n-true-entries (list-tail fill-list 1))) ; trill?
 511             ((rich-pe-stencil
 512               1.0
 513               1.0
 514               (degree-first-true fill-list #t #f)
 515               (degree-first-true fill-list #f #f)
 516               identity)
 517               radius
 518               thick
 519               (assoc-get 'F HOLE-FILL-LIST)
 520               layout
 521               props)
 522             empty-stencil))))))
 523
 524 (define (variable-column-circle-stencil scaler)
 525   (lambda (radius thick fill layout props)
 526     (column-circle-stencil (* radius scaler) thick fill layout props)))
 527
 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)))
 531     (ly:stencil-add
 532       ((if
 533         (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
 534         gray-colorize
 535         identity)
 536         ((standard-e-stencil
 537             (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))
 538             (* (+ (- 1.0 (* 2 thick)) (/ thick 2))))
 539           radius
 540           (* (* 4 radius) thick)
 541           1
 542           layout
 543           props))
 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))
 547         thick
 548         (*
 549           (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST)))
 550             (assoc-get 'F HOLE-FILL-LIST)
 551             1)
 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))))
 555         layout
 556         props))
 557     (column-circle-stencil radius thick fill layout props)))
 558
 559 ;;; Flute family stencils
 560
 561 (define flute-lh-b-key-stencil
 562   (standard-path-stencil
 563     '((0 1.3)
 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)
 566       (0 0.4 0 0.125 0 0))
 567     2
 568     1.55))
 569
 570 (define flute-lh-bes-key-stencil
 571   (standard-path-stencil
 572     '((0 1.3)
 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)
 575       (0 0.4 0 0.125 0 0))
 576     2.0
 577     1.3))
 578
 579 (define (flute-lh-gis-rh-bes-key-stencil deg)
 580   (rich-path-stencil
 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))
 584     1.0
 585     1.0
 586     (lambda (stencil) (ly:stencil-rotate stencil deg 0 0))))
 587
 588 (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0))
 589
 590 (define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200))
 591
 592 (define flute-rh-d-key-stencil little-elliptical-key-stencil)
 593
 594 (define flute-rh-dis-key-stencil little-elliptical-key-stencil)
 595
 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))
 599     -2.38
 600     1.4))
 601
 602 (define (piccolo-rh-x-key-stencil radius thick fill layout props)
 603   (interpret-markup
 604     layout
 605     props
 606     (make-general-align-markup
 607       Y
 608       DOWN
 609       (make-concat-markup
 610         (make-name-keylist
 611           `(,(text-fill-translate fill))
 612           '(("X" . #f))
 613           (* 9 radius))))))
 614
 615 (define flute-lower-row-stretch 1.4)
 616
 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))
 622
 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))
 628
 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))
 634
 635 (define flute-rh-gz-key-stencil
 636   (rich-path-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))))
 643
 644 ;;; Shared oboe/clarinet stencils
 645
 646 (define (oboe-lh-gis-lh-low-b-key-stencil gis?)
 647   (let*
 648     ((x 1.2)
 649      (y 0.4)
 650      (scaling-factor 1.7)
 651      (up-part
 652        (car
 653          (split-bezier
 654            `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0))
 655            0.8)))
 656      (down-part
 657        (cdr
 658          (split-bezier
 659            `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
 660            0.2))))
 661     (if gis?
 662       (standard-path-stencil
 663         (append
 664           (append
 665             `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0))
 666             (map (lambda (l)
 667                    (flatten-list
 668                      (map (lambda (x)
 669                             (coord-translate
 670                               (coord-rotate x (atan (/ y (* 2 0.25))))
 671                               '(1.0 . 0)))
 672                           l)))
 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)))
 676         scaling-factor
 677         scaling-factor)
 678       (standard-path-stencil
 679         (map (lambda (l)
 680                (flatten-list
 681                  (map (lambda (x)
 682                         (coord-rotate x (atan (/ y (* 2 0.25)))))
 683                       l)))
 684              `(,(list-tail up-part 1)
 685                ,(list-head down-part 1)
 686                ,(list-tail down-part 1)))
 687         (- scaling-factor)
 688         (- scaling-factor)))))
 689
 690 (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t))
 691
 692 (define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f))
 693
 694 (define (oboe-lh-ees-lh-bes-key-stencil ees?)
 695   (standard-path-stencil
 696     `((0 1.5)
 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)
 699       (0 0.25 0 0.125 0 0)
 700       (0 ,(if ees? -0.6 -0.3)))
 701     (* (if ees? -1.0 1.0) -1.8)
 702     1.8))
 703
 704 (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t))
 705
 706 (define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f))
 707
 708 ;;; Oboe family stencils
 709
 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)
 714       (-0.1 ,h)
 715       (0.1 ,h)
 716       (0.1 1.0)
 717       (0.4 1.0 0.4 0 0 0))
 718     2.0
 719     2.0)))
 720
 721 (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f))
 722
 723 (define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f))
 724
 725 (define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t))
 726
 727 (define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8))
 728
 729 (define oboe-lh-d-key-stencil little-elliptical-key-stencil)
 730
 731 (define oboe-lh-cis-key-stencil little-elliptical-key-stencil)
 732
 733 (define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0))
 734
 735 (define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45))
 736
 737 (define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2))
 738
 739 (define oboe-rh-d-key-stencil little-elliptical-key-stencil)
 740
 741 (define oboe-rh-f-key-stencil little-elliptical-key-stencil)
 742
 743 (define (oboe-rh-c-rh-ees-key-stencil c?)
 744   (rich-path-stencil
 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)
 747       (1.0 -0.4 1.0 0 0 0)
 748       (-0.15 0))
 749     2.0
 750     1.4
 751     (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0))))
 752
 753 (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil)
 754
 755 (define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t))
 756
 757 (define oboe-rh-cis-key-stencil
 758   (rich-path-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))
 762     -0.9
 763     1.0
 764     (lambda (stencil) (ly:stencil-rotate stencil 0 0 0))))
 765
 766 (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f))
 767
 768 ;;; Clarinet family stencils
 769
 770 (define clarinet-lh-thumb-key-stencil
 771   (variable-column-circle-stencil 0.9))
 772
 773 (define clarinet-lh-R-key-stencil
 774   (let* ((halfbase (cos (/ PI 10)))
 775     (height (*
 776       halfbase
 777       (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
 778    (standard-path-stencil
 779       `(
 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))
 783       0.9
 784       0.9)))
 785
 786 (define (clarinet-lh-a-key-stencil radius thick fill layout props)
 787   (let* ((width 0.4) (height 0.75) (linelen 0.45))
 788   (ly:stencil-add
 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))))))
 793
 794 (define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 795
 796 (define clarinet-lh-ees-key-stencil little-elliptical-key-stencil)
 797
 798 (define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil)
 799
 800 (define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil)
 801
 802 (define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil)
 803
 804 (define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil)
 805
 806 (define clarinet-lh-d-key-stencil (standard-e-stencil 1.0 0.4))
 807
 808 (define clarinet-rh-low-c-key-stencil
 809   (standard-path-stencil
 810     '((0.0 1.5)
 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)
 813       (0.0 0.0))
 814     0.8
 815     0.8))
 816
 817 (define clarinet-rh-low-cis-key-stencil
 818   (standard-path-stencil
 819     '((0.0 1.17)
 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)
 822       (0.0 0.0))
 823     0.8
 824     0.8))
 825
 826 (define clarinet-rh-low-d-key-stencil
 827   (standard-path-stencil
 828     '((0.0 1.05)
 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)
 831       (0.0 0.0))
 832     0.8
 833     0.8))
 834
 835 (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25))
 836
 837 (define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil)
 838
 839 (define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil)
 840
 841 (define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil)
 842
 843 (define clarinet-rh-b-key-stencil little-elliptical-key-stencil)
 844
 845 ; cl low-rh values
 846 (define CL-RH-HAIR 0.09)
 847 (define CL-RH-H-STRETCH 2.7)
 848 (define CL-RH-V-STRETCH 0.9)
 849
 850 ; TODO
 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...
 854
 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))
 859         0.5)
 860       ,(bezier-head-for-stencil
 861         '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 862         0.5)
 863       (1.0 1.0 0.0 1.0 0.0 0.0))
 864       CL-RH-H-STRETCH
 865       CL-RH-V-STRETCH))
 866
 867 (define clarinet-rh-e-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))
 870     CL-RH-H-STRETCH
 871     CL-RH-V-STRETCH))
 872
 873 (define clarinet-rh-ees-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))
 877         0.5)
 878       ,(bezier-head-for-stencil
 879         '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 880         0.5)
 881       ,(bezier-head-for-stencil
 882         `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 .  1.5))
 883         0.5)
 884        ,(bezier-head-for-stencil
 885         `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75))
 886         0.5))
 887     CL-RH-H-STRETCH
 888     CL-RH-V-STRETCH))
 889
 890 (define clarinet-rh-gis-key-stencil clarinet-rh-e-key-stencil)
 891
 892 (define bass-clarinet-rh-f-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))
 896         0.5)
 897       ,(bezier-head-for-stencil
 898         '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 899         0.5)
 900       (1.0 1.0 0.0 1.0 0.0 0.0))
 901     CL-RH-H-STRETCH
 902     (- CL-RH-V-STRETCH)))
 903
 904 (define low-bass-clarinet-rh-f-key-stencil clarinet-rh-ees-key-stencil)
 905
 906 (define clarinet-rh-d-key-stencil clarinet-rh-e-key-stencil)
 907
 908 ;;; Saxophone family stencils
 909
 910 (define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 911
 912 (define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 913
 914 (define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 915
 916 (define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.7 0.7))
 917
 918 (define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5))
 919
 920 (define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75))
 921
 922 (define saxophone-lh-gis-key-stencil
 923   (standard-path-stencil
 924     '((0.0 0.4)
 925       (0.0 0.8 3.0 0.8 3.0 0.4)
 926       (3.0 0.0)
 927       (3.0 -0.4 0.0 -0.4 0.0 0.0))
 928     0.8
 929     0.8))
 930
 931 (define (saxophone-lh-b-cis-key-stencil flip?)
 932   (standard-path-stencil
 933     '((0.0 1.0)
 934       (0.4 1.0 0.8 0.9 1.35 0.8)
 935       (1.35 0.0)
 936       (0.0 0.0))
 937     (* (if flip? -1 1) 0.8)
 938     0.8))
 939
 940 (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t))
 941
 942 (define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f))
 943
 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))
 947     0.8
 948     0.8))
 949
 950 (define (saxophone-rh-side-key-stencil width height)
 951   (standard-path-stencil
 952     `((0.0 ,height)
 953     (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15))
 954     (,(- width 0.15) ,(+ height 0.15))
 955     (,(- width 0.1)
 956      ,(+ height 0.1)
 957      ,(- width 0.05)
 958      ,(+ height 0.05)
 959      ,width
 960      ,height)
 961     (,width 0.0)
 962     (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15)
 963     (0.15 -0.15)
 964     (0.1 -0.1 0.05 -0.05 0.0 0.0))
 965     1.0
 966     1.0))
 967
 968 (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2))
 969
 970 (define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.9 0.6))
 971
 972 (define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.9 0.45))
 973
 974 (define saxophone-rh-high-fis-key-stencil
 975   (standard-path-stencil
 976     (append
 977       '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
 978       (map (lambda (l)
 979              (flatten-list
 980                (map (lambda (x)
 981                       (coord-rotate x (atan (* -1 (/ PI 6)))))
 982                     l)))
 983            '(((0.6 . -1.0))
 984              ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
 985              ((0.0 . 0.0)))))
 986        0.75
 987        0.75))
 988
 989 (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5))
 990
 991 (define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5))
 992
 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))
 996     0.8
 997     0.8))
 998
 999 (define (saxophone-lh-low-a-key-stencil radius thick fill layout props)
1000   (interpret-markup
1001     layout
1002     props
1003     (make-general-align-markup
1004       Y
1005       DOWN
1006       (make-concat-markup
1007         (make-name-keylist
1008           `(,(text-fill-translate fill))
1009           '(("lowA" . #f))
1010           (* 9 radius))))))
1011
1012 ;;; Bassoon family stencils
1013
1014 (define (bassoon-bend-info-maker height gap cut)
1015   (let* (
1016     (first-bezier
1017       (flatten-list
1018         (car
1019           (split-bezier
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))))
1024              cut))))
1025     (second-bezier
1026       (flatten-list
1027         (reverse
1028           (car
1029             (split-bezier
1030               `((1.0 . ,height)
1031                (1.0 . ,(+ 0.5 height))
1032                (1.5 . ,(+ 1.0 height))
1033                (2.0 . ,(+ 1.0 height)))
1034               cut)))))
1035     (slope-offset1
1036       (get-slope-offset
1037         `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5))
1038         `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7))))
1039     (slope-offset2
1040       (get-slope-offset
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)))
1044
1045 (define
1046   (make-tilted-portion
1047     first-bezier
1048     second-bezier
1049     slope-offset1
1050     slope-offset2
1051     keylen
1052     bezier?)
1053   (append
1054     `((,(+ keylen (list-ref first-bezier 6))
1055      ,(+
1056         (*
1057           (car slope-offset1)
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))
1061        ,(+
1062           (*
1063             (car slope-offset1)
1064             (+ (+ keylen 1.75) (list-ref first-bezier 6)))
1065           (cdr slope-offset1)))
1066        (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
1067        ,(+
1068           (*
1069             (car slope-offset2)
1070             (+ (+ keylen 1.75) (list-ref second-bezier 0)))
1071           (cdr slope-offset2)))
1072        (,(+ keylen (list-ref second-bezier 0))
1073         ,(+
1074           (* (car slope-offset2)  (+ keylen (list-ref second-bezier 0)))
1075           (cdr slope-offset2)))))
1076     `(,(list-head second-bezier 2))))
1077
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)))
1084   (rich-path-stencil
1085     (append
1086       `((0.0 ,(+ height gap))
1087       ,(list-tail first-bezier 2))
1088       (make-tilted-portion
1089         first-bezier
1090         second-bezier
1091         slope-offset1
1092         slope-offset2
1093         keylen
1094         bezier?)
1095       `(,(list-tail second-bezier 2)
1096       (1.0 0.0)
1097       (0.0 0.0)))
1098     d1
1099     d2
1100     proc)))
1101
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))
1104
1105 (define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8))
1106
1107 (define bassoon-lh-he-key-stencil little-elliptical-key-stencil)
1108
1109 (define bassoon-lh-hees-key-stencil little-elliptical-key-stencil)
1110
1111 (define bassoon-lh-ees-key-stencil
1112   (rich-e-stencil
1113     1.2
1114     0.6
1115    (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1116
1117 (define bassoon-lh-cis-key-stencil
1118   (rich-e-stencil
1119     1.0
1120     0.5
1121     (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1122
1123 (define bassoon-lh-lbes-key-stencil
1124   (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6))
1125
1126 (define bassoon-lh-lb-key-stencil
1127   (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6))
1128
1129 (define bassoon-lh-lc-key-stencil
1130   (rich-pe-stencil 1.0 1.0 135 315 identity))
1131
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)
1137       (0.5 -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))
1140     1.0
1141     1.0))
1142
1143 (define bassoon-lh-d-flick-key-stencil
1144   (let ((height 3.0))
1145     (standard-path-stencil
1146       `((0.0 ,height)
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))
1151        (0.4 0.0)
1152        (0.0 0.0))
1153       -1.0
1154       -1.0)))
1155
1156 (define bassoon-lh-c-flick-key-stencil
1157   (let ((height 3.0))
1158     (standard-path-stencil
1159       `((0.0 ,height)
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))
1164          (0.4 0.0)
1165          (0.0 0.0))
1166       -1.0
1167       -1.0)))
1168
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))
1171
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))
1174
1175 (define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7))
1176
1177 (define bassoon-rh-cis-key-stencil
1178   (rich-bassoon-uber-key-stencil
1179     1.1
1180     1.5
1181     0.9
1182     0.3
1183     0.5
1184     0.5
1185     (lambda (stencil) (ly:stencil-rotate stencil -76 0 0))
1186     #t))
1187
1188 (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil)
1189
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))
1192
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
1201     (append
1202       (map
1203         (lambda (l)
1204           (rotunda-map
1205             -
1206             l
1207             (list-tail first-bezier 6)))
1208         (make-tilted-portion
1209           first-bezier
1210           second-bezier
1211           slope-offset1
1212           slope-offset2
1213           keylen
1214           #t))
1215       '((0.0 0.0)))
1216     -0.7
1217     0.7)))
1218
1219 (define bassoon-rh-gis-key-stencil
1220   (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7))
1221
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))
1224
1225 (define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7))
1226
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))
1229
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))