scm/define-woodwind-diagrams.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2010--2015 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 (string-concatenate (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   (fold
  37    (lambda (fun arg) (apply (car fun) arg (cdr fun)))
  38    arg
  39    function-list))
  40
  41 (define (assoc-keys alist)
  42   "Gets the keys of an alist."
  43   (map car alist))
  44
  45 (define (assoc-values alist)
  46   "Gets the values of an alist."
  47   (map cdr alist))
  48
  49 (define (get-slope-offset p1 p2)
  50   "Gets the slope and offset for p1 and p2.
  51    For example:
  52    @code{(get-slope-offset '(1 . 2) '(3 . -5.1))}
  53    @code{(-3.55 . 5.55)}"
  54   (let*
  55       ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2))))
  56        (offset (- (cdr p1) (* slope (car p1)))))
  57     `(,slope . ,offset)))
  58
  59 (define (is-square? x input-list)
  60   "Returns true if x is the square of a value in input-list."
  61   (pair? (memv (inexact->exact (sqrt x)) input-list)))
  62
  63 (define (true-entry? input-list)
  64   "Is there a true entry in @code{input-list}?"
  65   (any identity input-list))
  66
  67 (define (entry-greater-than-x? input-list x)
  68   "Is there an entry greater than @code{x} in @code{input-list}?"
  69   (member x input-list <))
  70
  71 (define (n-true-entries input-list)
  72   "Returns number of true entries in @code{input-list}."
  73   (count identity input-list))
  74
  75 (define (bezier-head-for-stencil bezier cut-point)
  76   "Prepares a split-bezier to be used in a connected path stencil."
  77   (list-tail (flatten-list (car (split-bezier bezier cut-point))) 2))
  78
  79 ;; Translators for keys
  80
  81 ;; Translates a "normal" key (open, closed, trill)
  82 (define (key-fill-translate fill)
  83   (cond
  84    ((= fill 1) #f)
  85    ((= fill 2) #f)
  86    ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
  87    ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t)))
  88
  89 ;; Similar to above, but trans vs opaque doesn't matter
  90 (define (text-fill-translate fill)
  91   (cond
  92    ((< fill 3) 1.0)
  93    ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
  94    ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0)))
  95
  96 ;; Emits a list for the central-column-hole maker
  97 ;; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?)
  98 ;; Multiple values, such as (#t #f #f #t #f), mean a trill between
  99 ;; not-full and 3-quarters-full
 100 (define (process-fill-value fill)
 101   (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1)))
 102     (append `(,(or (< fill 3) (is-square? fill avals)))
 103             (map (lambda (x) (= 0 (remainder fill x))) avals))))
 104
 105 ;; Color a stencil gray
 106 (define (gray-colorize stencil)
 107   (apply ly:stencil-in-color stencil (x11-color 'grey)))
 108
 109 ;; A connected path stencil that is surrounded by proc
 110 (define (rich-path-stencil ls x-stretch y-stretch proc)
 111   (lambda (radius thick fill layout props)
 112     (let*
 113         ((fill-translate (key-fill-translate fill))
 114          (gray? (eqv? fill-translate 0.5)))
 115       (ly:stencil-add
 116        ((if gray? gray-colorize identity)
 117         (proc
 118          (make-connected-path-stencil
 119           ls
 120           thick
 121           (* x-stretch radius)
 122           (* y-stretch radius)
 123           #f
 124           (if gray? #t fill-translate))))
 125        (if (not gray?)
 126            empty-stencil
 127            ((rich-path-stencil ls x-stretch y-stretch proc)
 128             radius
 129             thick
 130             1
 131             layout
 132             props))))))
 133
 134 ;; A connected path stencil without a surrounding proc
 135 (define (standard-path-stencil ls x-stretch y-stretch)
 136   (rich-path-stencil ls x-stretch y-stretch identity))
 137
 138 ;; An ellipse stencil that is surrounded by a proc
 139 (define (rich-pe-stencil x-stretch y-stretch start end 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-partial-ellipse-stencil
 148           (* x-stretch radius)
 149           (* y-stretch radius)
 150           start
 151           end
 152           thick
 153           #t
 154           (if gray? #t fill-translate))))
 155        (if (not gray?)
 156            empty-stencil
 157            ((rich-pe-stencil x-stretch y-stretch start end proc)
 158             radius
 159             thick
 160             1
 161             layout
 162             props))))))
 163
 164 (define (rich-e-stencil x-stretch y-stretch proc)
 165   (lambda (radius thick fill layout props)
 166     (let*
 167         ((fill-translate (key-fill-translate fill))
 168          (gray? (eqv? fill-translate 0.5)))
 169       (ly:stencil-add
 170        ((if gray? gray-colorize identity)
 171         (proc
 172          (make-ellipse-stencil
 173           (* x-stretch radius)
 174           (* y-stretch radius)
 175           thick
 176           (if gray? #t fill-translate))))
 177        (if (not gray?)
 178            empty-stencil
 179            ((rich-e-stencil x-stretch y-stretch proc)
 180             radius
 181             thick
 182             1
 183             layout
 184             props))))))
 185
 186 ;; An ellipse stencil without a surrounding proc
 187 (define (standard-e-stencil x-stretch y-stretch)
 188   (rich-e-stencil x-stretch y-stretch identity))
 189
 190 ;; Translates all possible representations of symbol.
 191 ;; If simple? then the only representations are open, closed, and trill.
 192 ;; Otherwise, there can be various levels of "closure" on the holes
 193 ;; ring? allows for a ring around the holes as well
 194 (define (make-symbol-alist symbol simple? ring?)
 195   (delete `(,(symbol-concatenate symbol 'T 'F) .
 196             ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))
 197           `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
 198             (,(symbol-concatenate symbol 'T) .
 199              ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))
 200             ,@(if simple?
 201                   '()
 202                   (append-map
 203                    (lambda (x)
 204                      `((,(symbol-concatenate symbol (car x) 'T)
 205                         . ,(expt (cdr x) 2))
 206                        (,(symbol-concatenate symbol 'T (car x))
 207                         . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
 208                        (,(symbol-concatenate symbol (car x))
 209                         . ,(cdr x))
 210                        ,@(append-map
 211                           (lambda (y)
 212                             (map (lambda (a b)
 213                                    `(,(symbol-concatenate symbol
 214                                                           (car a)
 215                                                           'T
 216                                                           (car b))
 217                                      . ,(* (cdr a) (cdr b))))
 218                                  `(,x ,y) `(,y ,x)))
 219                           (cdr (member x HOLE-FILL-LIST)))))
 220                    (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST)))))))
 221
 222 ;;; Commands for text layout
 223
 224 ;; Draws a circle around markup if (= trigger 0.5)
 225 (define-markup-command
 226   (conditional-circle-markup layout props trigger in-markup)
 227   (number? markup?)
 228   (interpret-markup layout props
 229                     (if (eqv? trigger 0.5)
 230                         (markup #:circle (markup in-markup))
 231                         (markup in-markup))))
 232
 233 ;; Makes a list of named-keys
 234 (define (make-name-keylist input-list key-list font-size)
 235   (map (lambda (x y)
 236          (if (< x 1)
 237              (markup #:conditional-circle-markup
 238                      x
 239                      (make-concat-markup
 240                       (list
 241                        (markup #:abs-fontsize font-size (car y))
 242                        (if (and (< x 1) (cdr y))
 243                            (if (eqv? (cdr y) 1)
 244                                (markup
 245                                 #:abs-fontsize
 246                                 font-size
 247                                 #:raise
 248                                 1
 249                                 #:fontsize
 250                                 -2
 251                                 #:sharp)
 252                                (markup
 253                                 #:abs-fontsize
 254                                 font-size
 255                                 #:raise
 256                                 1
 257                                 #:fontsize
 258                                 -2
 259                                 #:flat))
 260                            (markup #:null)))))
 261              (markup #:null)))
 262        input-list key-list))
 263
 264 ;; Makes a list of number-keys
 265 (define (make-number-keylist input-list key-list font-size)
 266   (map (lambda (x y)
 267          (if (< x 1)
 268              (markup
 269               #:conditional-circle-markup
 270               x
 271               (markup #:abs-fontsize font-size #:number y))
 272              (markup #:null)))
 273        input-list
 274        key-list))
 275
 276 ;; Creates a named-key list with a certain alignment
 277 (define (aligned-text-stencil-function dir hv)
 278   (lambda (key-name-list radius fill-list layout props)
 279     (interpret-markup
 280      layout
 281      props
 282      (make-general-align-markup
 283       X
 284       dir
 285       ((if hv make-concat-markup make-center-column-markup)
 286        (make-name-keylist
 287         (map text-fill-translate fill-list)
 288         key-name-list
 289         (* 12 radius)))))))
 290
 291 (define number-column-stencil
 292   (lambda (key-name-list radius fill-list layout props)
 293     (interpret-markup
 294      layout
 295      props
 296      (make-general-align-markup
 297       Y
 298       CENTER
 299       (make-general-align-markup
 300        X
 301        RIGHT
 302        (make-override-markup
 303         '(baseline-skip . 0)
 304         (make-column-markup
 305          (make-number-keylist
 306           (map text-fill-translate fill-list)
 307           key-name-list
 308           (* radius 8)))))))))
 309
 310 ;; Utility function for the left-hand keys
 311 (define lh-woodwind-text-stencil
 312   (aligned-text-stencil-function LEFT #t))
 313
 314 ;; Utility function for the right-hand keys
 315 (define rh-woodwind-text-stencil
 316   (aligned-text-stencil-function RIGHT #t))
 317
 318 (define octave-woodwind-text-stencil
 319   (aligned-text-stencil-function CENTER #f))
 320
 321 ;;; Draw rules
 322
 323 (define (rich-group-draw-rule alist target-part change-part)
 324   (if
 325    (entry-greater-than-x?
 326     (map (lambda (key) (assoc-get key alist)) target-part) 3)
 327    (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist)
 328    alist))
 329
 330 (define (bassoon-midline-rule alist target-part)
 331   (if
 332    (entry-greater-than-x?
 333     (map (lambda (key) (assoc-get key alist)) target-part) 0)
 334    (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist)
 335    (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist)))
 336
 337 (define (group-draw-rule alist target-part)
 338   (rich-group-draw-rule alist target-part target-part))
 339
 340 (define (group-automate-rule alist change-part)
 341   (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist))
 342
 343 (define (apply-group-draw-rule-series alist target-part-list)
 344   (if (null? target-part-list)
 345       alist
 346       (apply-group-draw-rule-series
 347        (group-draw-rule alist (car target-part-list))
 348        (cdr target-part-list))))
 349
 350 ;; Extra-offset rules
 351
 352 (define (rich-group-extra-offset-rule alist target-part change-part eos)
 353   (if
 354    (entry-greater-than-x?
 355     (map (lambda (key) (assoc-get key alist)) target-part) 0)
 356    (map-selected-alist-keys (lambda (x) eos) change-part alist)
 357    alist))
 358
 359 (define (group-extra-offset-rule alist target-part eos)
 360   (rich-group-extra-offset-rule alist target-part target-part eos))
 361
 362 (define (uniform-extra-offset-rule alist eos)
 363   (map-selected-alist-keys
 364    (lambda (x) (if (pair? x) x eos))
 365    (assoc-keys alist)
 366    alist))
 367
 368 ;;; General drawing commands
 369
 370 ;; Used all the time for a dividing line
 371 (define (midline-stencil radius thick fill layout props)
 372   (make-line-stencil (* thick 2) (* -0.80 radius) 0 (* 0.80 radius) 0))
 373
 374 (define (long-midline-stencil radius thick fill layout props)
 375   (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0))
 376
 377 ;; Used all the time for a small, between-hole key
 378 (define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2))
 379
 380 ;; Used for several upper keys in the clarinet and sax
 381 (define (upper-key-stencil tailw tailh bodyw bodyh)
 382   (let*
 383       ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2))))))
 384        (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05)))))))
 385     (standard-path-stencil
 386      `((,(xmove 0.7)
 387         ,(ymove -0.2)
 388         ,(xmove 1.0)
 389         ,(ymove -1.0)
 390         ,(xmove 0.5)
 391         ,(ymove -1.0))
 392        (,(xmove 0.2)
 393         ,(ymove -1.0)
 394         ,(xmove 0.2)
 395         ,(ymove -0.2)
 396         ,(xmove 0.3)
 397         ,(ymove -0.1))
 398        (,(+ 0.2 tailw)
 399         ,(- -0.05 tailh)
 400         ,(+ 0.1 (/ tailw 2))
 401         ,(- -0.025 (/ tailh 2))
 402         0.0
 403         0.0))
 404      1.0
 405      1.0)))
 406
 407 ;; Utility function for the column-hole maker.
 408 ;; Returns the left and right degrees for the drawing of a given
 409 ;; fill level (1-quarter, 1-half, etc...)
 410 (define (degree-first-true fill-list left? reverse?)
 411   (define (dfl-crawler fill-list os-list left?)
 412     (if (car fill-list)
 413         ((if left? car cdr) (car os-list))
 414         (dfl-crawler (cdr fill-list) (cdr os-list) left?)))
 415   (dfl-crawler
 416    ((if reverse? reverse identity) fill-list)
 417    ((if reverse? reverse identity)
 418     '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90)))
 419    left?))
 420
 421 ;; Gets the position of the first (or last if reverse?) element of a list.
 422 (define (position-true-endpoint in-list reverse?)
 423   (define (pte-crawler in-list n)
 424     (if (car in-list)
 425         n
 426         (pte-crawler (cdr in-list) (+ n 1))))
 427   ((if reverse? - +)
 428    (if reverse? (length in-list) 0)
 429    (pte-crawler ((if reverse? reverse identity) in-list) 0)))
 430
 431 ;; Huge, kind-of-ugly maker of a circle in a column.
 432 ;; I think this is the clearest way to write it, though...
 433
 434 (define (column-circle-stencil radius thick fill layout props)
 435   (let* ((fill-list (process-fill-value fill)))
 436     (cond
 437      ((and
 438        (list-ref fill-list 0)
 439        (not (true-entry? (list-tail fill-list 1)))) ; is it empty?
 440       ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
 441      ((and
 442        (list-ref fill-list 4)
 443        (not (true-entry? (list-head fill-list 4)))) ; is it full?
 444       ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
 445      ((and
 446        (list-ref fill-list 0)
 447        (list-ref fill-list 4)) ; is it a trill between empty and full?
 448       ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
 449      (else  ;If none of these, it is partially full.
 450       (ly:stencil-add
 451        ((rich-pe-stencil 1.0 1.0 0 360 identity)
 452         radius
 453         thick
 454         (if (list-ref fill-list 4)
 455             (expt (assoc-get 'F HOLE-FILL-LIST) 2)
 456             1)
 457         layout
 458         props)
 459        ((rich-pe-stencil
 460          1.0
 461          1.0
 462          (degree-first-true fill-list #t #t)
 463          (degree-first-true fill-list #f #t)
 464          identity)
 465         radius
 466         thick
 467         (if
 468          (true-entry?
 469           (list-head fill-list (position-true-endpoint fill-list #t)))
 470          (expt (assoc-get 'F HOLE-FILL-LIST) 2)
 471          (assoc-get 'F HOLE-FILL-LIST))
 472         layout
 473         props)
 474        (if
 475         (= 2 (n-true-entries (list-tail fill-list 1))) ; trill?
 476         ((rich-pe-stencil
 477           1.0
 478           1.0
 479           (degree-first-true fill-list #t #f)
 480           (degree-first-true fill-list #f #f)
 481           identity)
 482          radius
 483          thick
 484          (assoc-get 'F HOLE-FILL-LIST)
 485          layout
 486          props)
 487         empty-stencil))))))
 488
 489 (define (variable-column-circle-stencil scaler)
 490   (lambda (radius thick fill layout props)
 491     (column-circle-stencil (* radius scaler) thick fill layout props)))
 492
 493 ;; A stencil for ring-column circles that combines two of the above
 494 (define (ring-column-circle-stencil radius thick fill layout props)
 495   (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST)))
 496       (ly:stencil-add
 497        ((if
 498          (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
 499          gray-colorize
 500          identity)
 501         ((standard-e-stencil
 502           (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))
 503           (* (+ (- 1.0 (* 2 thick)) (/ thick 2))))
 504          radius
 505          (* (* 4 radius) thick)
 506          1
 507          layout
 508          props))
 509        ((standard-e-stencil 1.0 1.0) radius thick 1 layout props)
 510        (column-circle-stencil
 511         (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2))
 512         thick
 513         (*
 514          (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST)))
 515              (assoc-get 'F HOLE-FILL-LIST)
 516              1)
 517          (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
 518              (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
 519              (/ fill (assoc-get 'R HOLE-FILL-LIST))))
 520         layout
 521         props))
 522       (column-circle-stencil radius thick fill layout props)))
 523
 524 ;;; Flute family stencils
 525
 526 (define flute-lh-b-key-stencil
 527   (standard-path-stencil
 528    '((0 1.3)
 529      (0 1.625 -0.125 1.75 -0.25 1.75)
 530      (-0.55 1.75 -0.55 0.95 -0.25 0.7)
 531      (0 0.4 0 0.125 0 0))
 532    2
 533    1.55))
 534
 535 (define flute-lh-bes-key-stencil
 536   (standard-path-stencil
 537    '((0 1.3)
 538      (0 1.625 -0.125 1.75 -0.25 1.75)
 539      (-0.55 1.75 -0.55 0.95 -0.25 0.7)
 540      (0 0.4 0 0.125 0 0))
 541    2.0
 542    1.3))
 543
 544 (define (flute-lh-gis-rh-bes-key-stencil deg)
 545   (rich-path-stencil
 546    '((0.1 0.1 0.2 0.4 0.3 0.6)
 547      (0.3 1.0 0.8 1.0 0.8 0.7)
 548      (0.8 0.3 0.5 0.3 0 0))
 549    1.0
 550    1.0
 551    (lambda (stencil) (ly:stencil-rotate stencil deg 0 0))))
 552
 553 (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0))
 554
 555 (define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200))
 556
 557 (define flute-rh-d-key-stencil little-elliptical-key-stencil)
 558
 559 (define flute-rh-dis-key-stencil little-elliptical-key-stencil)
 560
 561 (define flute-rh-ees-key-stencil
 562   (standard-path-stencil
 563    '((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))
 564    -2.38
 565    1.4))
 566
 567 (define (piccolo-rh-x-key-stencil radius thick fill layout props)
 568   (interpret-markup
 569    layout
 570    props
 571    (make-general-align-markup
 572     Y
 573     DOWN
 574     (make-concat-markup
 575      (make-name-keylist
 576       `(,(text-fill-translate fill))
 577       '(("X" . #f))
 578       (* 9 radius))))))
 579
 580 (define flute-lower-row-stretch 1.4)
 581
 582 (define flute-rh-cis-key-stencil
 583   (standard-path-stencil
 584    '((0 0.75) (-0.8 0.75 -0.8 0 0 0))
 585    flute-lower-row-stretch
 586    flute-lower-row-stretch))
 587
 588 (define flute-rh-c-key-stencil
 589   (standard-path-stencil
 590    '((0 0.75) (0.4 0.75) (0.4 0) (0 0))
 591    flute-lower-row-stretch
 592    flute-lower-row-stretch))
 593
 594 (define flute-rh-b-key-stencil
 595   (standard-path-stencil
 596    '((0 0.75) (0.25 0.75) (0.25 0) (0 0))
 597    flute-lower-row-stretch
 598    flute-lower-row-stretch))
 599
 600 (define flute-rh-gz-key-stencil
 601   (rich-path-stencil
 602    '((0.1 0.1 0.4 0.2 0.6 0.3)
 603      (1.0 0.3 1.0 0.8 0.7 0.8)
 604      (0.3 0.8 0.3 0.5 0 0))
 605    flute-lower-row-stretch
 606    flute-lower-row-stretch
 607    (lambda (stencil) (ly:stencil-rotate stencil 160 0 0))))
 608
 609 ;;; Shared oboe/clarinet stencils
 610
 611 (define (oboe-lh-gis-lh-low-b-key-stencil gis?)
 612   (let*
 613       ((x 1.2)
 614        (y 0.4)
 615        (scaling-factor 1.7)
 616        (up-part
 617         (car
 618          (split-bezier
 619           `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0))
 620           0.8)))
 621        (down-part
 622         (cdr
 623          (split-bezier
 624           `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
 625           0.2))))
 626     (if gis?
 627         (standard-path-stencil
 628          (append
 629           (append
 630            `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0))
 631            (map (lambda (l)
 632                   (flatten-list
 633                    (map (lambda (x)
 634                           (coord-translate
 635                            (coord-rotated x (cons y (* 2 0.25)))
 636                            '(1.0 . 0)))
 637                         l)))
 638                 `(((0 . ,y) (,x . ,y) (,x . 0))
 639                   ((,x . ,(- y)) (0 . ,(- y)) (0 . 0)))))
 640           `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0)))
 641          scaling-factor
 642          scaling-factor)
 643         (standard-path-stencil
 644          (map (lambda (l)
 645                 (flatten-list
 646                  (map (lambda (x)
 647                         (coord-rotated x (cons y (* 2 0.25))))
 648                       l)))
 649               `(,(list-tail up-part 1)
 650                 ,(list-head down-part 1)
 651                 ,(list-tail down-part 1)))
 652          (- scaling-factor)
 653          (- scaling-factor)))))
 654
 655 (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t))
 656
 657 (define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f))
 658
 659 (define (oboe-lh-ees-lh-bes-key-stencil ees?)
 660   (standard-path-stencil
 661    `((0 1.5)
 662      (0 1.625 -0.125 1.75 -0.25 1.75)
 663      (-0.5 1.75 -0.5 0.816 -0.25 0.5)
 664      (0 0.25 0 0.125 0 0)
 665      (0 ,(if ees? -0.6 -0.3)))
 666    (* (if ees? -1.0 1.0) -1.8)
 667    1.8))
 668
 669 (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t))
 670
 671 (define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f))
 672
 673 ;;; Oboe family stencils
 674
 675 (define (oboe-lh-octave-key-stencil long?)
 676   (let* ((h (if long? 1.4 1.2)))
 677     (standard-path-stencil
 678      `((-0.4 0 -0.4 1.0 -0.1 1.0)
 679        (-0.1 ,h)
 680        (0.1 ,h)
 681        (0.1 1.0)
 682        (0.4 1.0 0.4 0 0 0))
 683      2.0
 684      2.0)))
 685
 686 (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f))
 687
 688 (define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f))
 689
 690 (define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t))
 691
 692 (define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8))
 693
 694 (define oboe-lh-d-key-stencil little-elliptical-key-stencil)
 695
 696 (define oboe-lh-cis-key-stencil little-elliptical-key-stencil)
 697
 698 (define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0))
 699
 700 (define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45))
 701
 702 (define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2))
 703
 704 (define oboe-rh-d-key-stencil little-elliptical-key-stencil)
 705
 706 (define oboe-rh-f-key-stencil little-elliptical-key-stencil)
 707
 708 (define (oboe-rh-c-rh-ees-key-stencil c?)
 709   (rich-path-stencil
 710    '((1.0 0.0 1.0 0.70 1.5 0.70)
 711      (2.25 0.70 2.25 -0.4 1.5 -0.4)
 712      (1.0 -0.4 1.0 0 0 0)
 713      (-0.15 0))
 714    2.0
 715    1.4
 716    (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0))))
 717
 718 (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil)
 719
 720 (define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t))
 721
 722 (define oboe-rh-cis-key-stencil
 723   (rich-path-stencil
 724    '((0.6 0.0 0.6 0.50 1.25 0.50)
 725      (2.25 0.50 2.25 -0.4 1.25 -0.4)
 726      (0.6 -0.4 0.6 0 0 0))
 727    -0.9
 728    1.0
 729    (lambda (stencil) (ly:stencil-rotate stencil 0 0 0))))
 730
 731 (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f))
 732
 733 ;;; Clarinet family stencils
 734
 735 (define clarinet-lh-thumb-key-stencil
 736   (variable-column-circle-stencil 0.9))
 737
 738 (define clarinet-lh-R-key-stencil
 739   (let* ((halfbase (cos (/ PI 10)))
 740          (height (*
 741                   halfbase
 742                   (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
 743     (standard-path-stencil
 744      `(
 745        (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0)
 746        (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height)
 747        (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0))
 748      0.9
 749      0.9)))
 750
 751 (define (clarinet-lh-a-key-stencil radius thick fill layout props)
 752   (let* ((width 0.4) (height 0.75) (linelen 0.45))
 753     (ly:stencil-add
 754      ((standard-e-stencil width height) radius thick fill layout props)
 755      (ly:stencil-translate
 756       (make-line-stencil thick 0 0 0 (* linelen radius))
 757       (cons 0 (* height radius))))))
 758
 759 (define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 760
 761 (define clarinet-lh-ees-key-stencil little-elliptical-key-stencil)
 762
 763 (define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil)
 764
 765 (define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil)
 766
 767 (define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil)
 768
 769 (define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil)
 770
 771 (define clarinet-lh-d-key-stencil (standard-e-stencil 1.0 0.4))
 772
 773 (define clarinet-rh-low-c-key-stencil
 774   (standard-path-stencil
 775    '((0.0 1.5)
 776      (0.0 2.5 -1.0 2.5 -1.0 0.75)
 777      (-1.0 0.1 0.0 0.25 0.0 0.3)
 778      (0.0 0.0))
 779    0.8
 780    0.8))
 781
 782 (define clarinet-rh-low-cis-key-stencil
 783   (standard-path-stencil
 784    '((0.0 1.17)
 785      (0.0 1.67 -1.0 1.67 -1.0 0.92)
 786      (-1.0 0.47 0.0 0.52 0.0 0.62)
 787      (0.0 0.0))
 788    0.8
 789    0.8))
 790
 791 (define clarinet-rh-low-d-key-stencil
 792   (standard-path-stencil
 793    '((0.0 1.05)
 794      (0.0 1.55 -1.0 1.55 -1.0 0.8)
 795      (-1.0 0.35 0.0 0.4 0.0 0.5)
 796      (0.0 0.0))
 797    0.8
 798    0.8))
 799
 800 (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25))
 801
 802 (define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil)
 803
 804 (define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil)
 805
 806 (define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil)
 807
 808 (define clarinet-rh-b-key-stencil little-elliptical-key-stencil)
 809
 810 ;; cl low-rh values
 811 (define CL-RH-HAIR 0.09)
 812 (define CL-RH-H-STRETCH 2.7)
 813 (define CL-RH-V-STRETCH 0.9)
 814
 815 ;; TODO
 816 ;; there is some unnecessary information duplication here.
 817 ;; need a way to control all of the below stencils so that if one
 818 ;; changes, all change...
 819
 820 (define clarinet-rh-fis-key-stencil
 821   (standard-path-stencil
 822    `(,(bezier-head-for-stencil
 823        '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
 824        0.5)
 825      ,(bezier-head-for-stencil
 826        '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 827        0.5)
 828      (1.0 1.0 0.0 1.0 0.0 0.0))
 829    CL-RH-H-STRETCH
 830    CL-RH-V-STRETCH))
 831
 832 (define clarinet-rh-gis-key-stencil
 833   (standard-path-stencil
 834    '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0))
 835    CL-RH-H-STRETCH
 836    CL-RH-V-STRETCH))
 837
 838 (define clarinet-rh-e-key-stencil
 839   (standard-path-stencil
 840    `(,(bezier-head-for-stencil
 841        '((0.0 .  0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
 842        0.5)
 843      ,(bezier-head-for-stencil
 844        '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 845        0.5)
 846      ,(bezier-head-for-stencil
 847        `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 .  1.5))
 848        0.5)
 849      ,(bezier-head-for-stencil
 850        `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75))
 851        0.5))
 852    CL-RH-H-STRETCH
 853    CL-RH-V-STRETCH))
 854
 855 (define clarinet-rh-f-key-stencil clarinet-rh-gis-key-stencil)
 856
 857 (define bass-clarinet-rh-ees-key-stencil
 858   (standard-path-stencil
 859    `(,(bezier-head-for-stencil
 860        '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
 861        0.5)
 862      ,(bezier-head-for-stencil
 863        '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
 864        0.5)
 865      (1.0 1.0 0.0 1.0 0.0 0.0))
 866    CL-RH-H-STRETCH
 867    (- CL-RH-V-STRETCH)))
 868
 869 (define low-bass-clarinet-rh-ees-key-stencil clarinet-rh-e-key-stencil)
 870
 871 (define clarinet-rh-d-key-stencil clarinet-rh-gis-key-stencil)
 872
 873 ;;; Saxophone family stencils
 874
 875 (define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 876
 877 (define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 878
 879 (define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
 880
 881 (define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.7 0.7))
 882
 883 (define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5))
 884
 885 (define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75))
 886
 887 (define saxophone-lh-gis-key-stencil
 888   (standard-path-stencil
 889    '((0.0 0.4)
 890      (0.0 0.8 3.0 0.8 3.0 0.4)
 891      (3.0 0.0)
 892      (3.0 -0.4 0.0 -0.4 0.0 0.0))
 893    0.8
 894    0.8))
 895
 896 (define (saxophone-lh-b-cis-key-stencil flip?)
 897   (standard-path-stencil
 898    '((0.0 1.0)
 899      (0.4 1.0 0.8 0.9 1.35 0.8)
 900      (1.35 0.0)
 901      (0.0 0.0))
 902    (* (if flip? -1 1) 0.8)
 903    0.8))
 904
 905 (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t))
 906
 907 (define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f))
 908
 909 (define saxophone-lh-low-bes-key-stencil
 910   (standard-path-stencil
 911    '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
 912    0.8
 913    0.8))
 914
 915 (define (saxophone-rh-side-key-stencil width height)
 916   (standard-path-stencil
 917    `((0.0 ,height)
 918      (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15))
 919      (,(- width 0.15) ,(+ height 0.15))
 920      (,(- width 0.1)
 921       ,(+ height 0.1)
 922       ,(- width 0.05)
 923       ,(+ height 0.05)
 924       ,width
 925       ,height)
 926      (,width 0.0)
 927      (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15)
 928      (0.15 -0.15)
 929      (0.1 -0.1 0.05 -0.05 0.0 0.0))
 930    1.0
 931    1.0))
 932
 933 (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2))
 934
 935 (define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.9 0.6))
 936
 937 (define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.9 0.45))
 938
 939 (define saxophone-rh-high-fis-key-stencil
 940   (standard-path-stencil
 941    (let* ((angle -30)
 942           (dir2 (ly:directed (* -0.5 angle)))
 943           ;; This comparatively awful expression calculates how far
 944           ;; along the tangents opened by 'angle' with a radius of 0.6
 945           ;; the control points need to move in order to have the
 946           ;; middle of the bezier curve exactly on radius.
 947           (out (* 0.6 (coord-y dir2) (- 4/3 (* 1/3 (coord-x dir2))))))
 948      (append
 949       '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
 950       `((0.6 ,(- out)
 951              ,@(flatten-list (map (lambda (x) (coord-rotated x angle))
 952                                   `((0.6 . ,out)
 953                                     (0.6 . 0.0))))))
 954       (map (lambda (l)
 955              (flatten-list
 956               (map (lambda (x)
 957                      (coord-rotated x angle))
 958                    l)))
 959            '(((0.6 . -1.0))
 960              ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
 961              ((0.0 . 0.0))))))
 962    0.75
 963    0.75))
 964
 965 (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5))
 966
 967 (define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5))
 968
 969 (define saxophone-rh-low-c-key-stencil
 970   (standard-path-stencil
 971    '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
 972    0.8
 973    0.8))
 974
 975 (define (saxophone-lh-low-a-key-stencil radius thick fill layout props)
 976   (interpret-markup
 977    layout
 978    props
 979    (make-general-align-markup
 980     Y
 981     DOWN
 982     (make-concat-markup
 983      (make-name-keylist
 984       `(,(text-fill-translate fill))
 985       '(("lowA" . #f))
 986       (* 9 radius))))))
 987
 988 ;;; Bassoon family stencils
 989
 990 (define (bassoon-bend-info-maker height gap cut)
 991   (let* (
 992          (first-bezier
 993           (flatten-list
 994            (car
 995             (split-bezier
 996              `((0.0 . ,(+ height gap))
 997                (0.0 . ,(+ height (+ gap 1.0)))
 998                (1.0 . ,(+ height (+ gap 2.0)))
 999                (2.0 . ,(+ height (+ gap 2.0))))
1000              cut))))
1001          (second-bezier
1002           (flatten-list
1003            (reverse
1004             (car
1005              (split-bezier
1006               `((1.0 . ,height)
1007                 (1.0 . ,(+ 0.5 height))
1008                 (1.5 . ,(+ 1.0 height))
1009                 (2.0 . ,(+ 1.0 height)))
1010               cut)))))
1011          (slope-offset1
1012           (get-slope-offset
1013            `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5))
1014            `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7))))
1015          (slope-offset2
1016           (get-slope-offset
1017            `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1))
1018            `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3)))))
1019     (list first-bezier second-bezier slope-offset1 slope-offset2)))
1020
1021 (define
1022   (make-tilted-portion
1023    first-bezier
1024    second-bezier
1025    slope-offset1
1026    slope-offset2
1027    keylen
1028    bezier?)
1029   (append
1030    `((,(+ keylen (list-ref first-bezier 6))
1031       ,(+
1032         (*
1033          (car slope-offset1)
1034          (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1))))
1035    ((if bezier? (lambda (x) `(,(concatenate x))) identity)
1036     `((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
1037        ,(+
1038          (*
1039           (car slope-offset1)
1040           (+ (+ keylen 1.75) (list-ref first-bezier 6)))
1041          (cdr slope-offset1)))
1042       (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
1043        ,(+
1044          (*
1045           (car slope-offset2)
1046           (+ (+ keylen 1.75) (list-ref second-bezier 0)))
1047          (cdr slope-offset2)))
1048       (,(+ keylen (list-ref second-bezier 0))
1049        ,(+
1050          (* (car slope-offset2)  (+ keylen (list-ref second-bezier 0)))
1051          (cdr slope-offset2)))))
1052    `(,(list-head second-bezier 2))))
1053
1054 (define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?)
1055   (let* ((info-list (bassoon-bend-info-maker height gap cut))
1056          (first-bezier (car info-list))
1057          (second-bezier (cadr info-list))
1058          (slope-offset1 (caddr info-list))
1059          (slope-offset2 (cadddr info-list)))
1060     (rich-path-stencil
1061      (append
1062       `((0.0 ,(+ height gap))
1063         ,(list-tail first-bezier 2))
1064       (make-tilted-portion
1065        first-bezier
1066        second-bezier
1067        slope-offset1
1068        slope-offset2
1069        keylen
1070        bezier?)
1071       `(,(list-tail second-bezier 2)
1072         (1.0 0.0)
1073         (0.0 0.0)))
1074      d1
1075      d2
1076      proc)))
1077
1078 (define (bassoon-uber-key-stencil height gap cut keylen d1 d2)
1079   (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 identity #t))
1080
1081 (define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8))
1082
1083 (define bassoon-lh-he-key-stencil little-elliptical-key-stencil)
1084
1085 (define bassoon-lh-hees-key-stencil little-elliptical-key-stencil)
1086
1087 (define bassoon-lh-ees-key-stencil
1088   (rich-e-stencil
1089    1.2
1090    0.6
1091    (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1092
1093 (define bassoon-lh-cis-key-stencil
1094   (rich-e-stencil
1095    1.0
1096    0.5
1097    (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
1098
1099 (define bassoon-lh-lbes-key-stencil
1100   (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6))
1101
1102 (define bassoon-lh-lb-key-stencil
1103   (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6))
1104
1105 (define bassoon-lh-lc-key-stencil
1106   (rich-pe-stencil 1.0 1.0 135 315 identity))
1107
1108 (define bassoon-lh-ld-key-stencil
1109   (standard-path-stencil
1110    '((-0.8 4.0 1.4 4.0 0.6 0.0)
1111      (0.5 -0.5 0.5 -0.8 0.6 -1.0)
1112      (0.7 -1.2 0.8 -1.3 0.8 -1.8)
1113      (0.5 -1.8)
1114      (0.5 -1.4 0.4 -1.2 0.3 -1.1)
1115      (0.2 -1.0 0.1 -0.5 0.0 0.0))
1116    1.0
1117    1.0))
1118
1119 (define bassoon-lh-d-flick-key-stencil
1120   (let ((height 3.0))
1121     (standard-path-stencil
1122      `((0.0 ,height)
1123        (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8))
1124        (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0))
1125        (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3))
1126        (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1127        (0.4 0.0)
1128        (0.0 0.0))
1129      -1.0
1130      -1.0)))
1131
1132 (define bassoon-lh-c-flick-key-stencil
1133   (let ((height 3.0))
1134     (standard-path-stencil
1135      `((0.0 ,height)
1136        (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8))
1137        (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0))
1138        (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3))
1139        (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
1140        (0.4 0.0)
1141        (0.0 0.0))
1142      -1.0
1143      -1.0)))
1144
1145 (define bassoon-lh-a-flick-key-stencil
1146   (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5))
1147
1148 (define bassoon-lh-thumb-cis-key-stencil
1149   (bassoon-uber-key-stencil 1.5 1.5 0.6 0.6 -0.6 0.6))
1150
1151 (define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7))
1152
1153 (define bassoon-rh-cis-key-stencil
1154   (rich-bassoon-uber-key-stencil
1155    1.1
1156    1.5
1157    0.9
1158    0.3
1159    0.5
1160    0.5
1161    (lambda (stencil) (ly:stencil-rotate stencil -76 0 0))
1162    #t))
1163
1164 (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil)
1165
1166 (define bassoon-rh-fis-key-stencil
1167   (rich-bassoon-uber-key-stencil 0.5 1.0 0.8 1.5 -0.7 0.7 identity #f))
1168
1169 (define bassoon-rh-f-key-stencil
1170   (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5)
1171          (info-list (bassoon-bend-info-maker height gap cut))
1172          (first-bezier (car info-list))
1173          (second-bezier (cadr info-list))
1174          (slope-offset1 (caddr info-list))
1175          (slope-offset2 (cadddr info-list)))
1176     (standard-path-stencil
1177      (append
1178       (map
1179        (lambda (l)
1180          (map
1181           -
1182           l
1183           (apply circular-list (list-tail first-bezier 6))))
1184        (make-tilted-portion
1185         first-bezier
1186         second-bezier
1187         slope-offset1
1188         slope-offset2
1189         keylen
1190         #t))
1191       '((0.0 0.0)))
1192      -0.7
1193      0.7)))
1194
1195 (define bassoon-rh-gis-key-stencil
1196   (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7))
1197
1198 (define bassoon-rh-thumb-bes-key-stencil
1199   (bassoon-uber-key-stencil 1.0 1.0 0.9 1.0 0.7 0.7))
1200
1201 (define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7))
1202
1203 (define bassoon-rh-thumb-fis-key-stencil
1204   (bassoon-uber-key-stencil 1.0 1.2 0.9 1.0 0.7 0.7))
1205
1206 (define bassoon-rh-thumb-gis-key-stencil
1207   (bassoon-uber-key-stencil 1.2 0.8 0.9 0.4 0.7 0.7))