scm/define-woodwind-diagrams.scm

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