scm/define-woodwind-diagrams.scm

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