scm/display-woodwind-diagrams.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2010--2011 Mike Solomon <mikesol@stanfordalumni.org>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;; Constants
  19
  20 (define CENTRAL-COLUMN-HOLE-PLACEMENTS '((one . (0.0 . 6.5))
  21                                          (two . (0.0 . 5.5))
  22                                          (three . (0.0 . 4.5))
  23                                          (four . (0.0 . 3.0))
  24                                          (five . (0.0 . 2.0))
  25                                          (six . (0.0 . 1.0))))
  26
  27 (define CENTRAL-COLUMN-HOLE-LIST (map car CENTRAL-COLUMN-HOLE-PLACEMENTS))
  28 (define CENTRAL-COLUMN-HOLE-H-LIST (cons 'h CENTRAL-COLUMN-HOLE-LIST))
  29
  30 ;; Utility functions
  31
  32 (define (return-1 x) 1.0)
  33
  34 (define (make-spreadsheet parameter-list)
  35   "Makes a spreadsheet function with columns of parameter-list.
  36    This function can then be filled with rows.
  37    For example:
  38    @code{guile> ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6)))}
  39    @code{(((foo . 1) (bar . 2)) ((foo . 3) (bar . 4)) ((foo . 5) (bar . 6)))}"
  40   (lambda (ls)
  41     (map (lambda (list-to-translate)
  42            (map (lambda (name element)
  43                   `(,name . ,element))
  44                 parameter-list
  45                 list-to-translate))
  46          ls)))
  47
  48 (define (get-spreadsheet-column column spreadsheet)
  49   "Gets all the values in @code{column} form @code{spreadsheet}
  50    made by @{make-spreadsheet}.
  51    For example:
  52    @code{guile> (get-spreadsheet-column 'bar ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6))))}
  53    @code{(2 4 6)}"
  54   (map (lambda (row) (assoc-get column row)) spreadsheet))
  55
  56 (define (make-named-spreadsheet parameter-list)
  57   "Makes a named spreadsheet function with columns of parameter-list.
  58    This function can then be filled with named rows
  59    For example:
  60    @code{guile> ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6))))}
  61    @code{((x (foo . 1) (bar . 2)) (y (foo . 3) (bar . 4)) (z (foo . 5) (bar . 6)))}"
  62   (lambda (ls)
  63     (map (lambda (list-to-translate)
  64            `(,(list-ref list-to-translate 0)
  65             . ,(map (lambda (name element)
  66                       `(,name . ,element))
  67                     parameter-list
  68                     (list-tail list-to-translate 1))))
  69          ls)))
  70
  71 (define (get-named-spreadsheet-column column spreadsheet)
  72   "Gets all the values in @code{column} form @code{spreadsheet}
  73    made by @{make-named-spreadsheet}.
  74    For example:
  75    @code{guile> (get-spreadsheet-column 'bar ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6)))))}
  76    @code{((x . 2) (y . 4) (z . 6))}"
  77   (map
  78     (lambda (row) (cons (car row) (assoc-get column (cdr row))))
  79     spreadsheet))
  80
  81 (define make-key-alist
  82   (make-named-spreadsheet '(name offset graphical textual)))
  83
  84 (define (simple-stencil-alist stencil offset)
  85   "A stencil alist that contains one and only one stencil.
  86    Shorthand used repeatedly in various instruments."
  87   `((stencils . (,stencil))
  88     (offset . ,offset)
  89     (textual?  . #f)
  90     (xy-scale-function . (,return-1 . ,return-1))))
  91
  92 (define (make-central-column-hole-addresses keys)
  93   "Takes @code{keys} and ascribes them to the central column."
  94   (map
  95     (lambda (key) `(central-column . ,key))
  96     keys))
  97
  98 (define (make-key-symbols hand)
  99   "Takes @code{hand} and ascribes @code{key} to it."
 100   (lambda (keys)
 101     (map (lambda (key) `(,hand . ,key))
 102          keys)))
 103
 104 (define make-left-hand-key-addresses (make-key-symbols 'left-hand))
 105
 106 (define make-right-hand-key-addresses (make-key-symbols 'right-hand))
 107
 108 ;; Flute assembly instructions
 109
 110 (define flute-change-points
 111   ((make-named-spreadsheet '(piccolo flute flute-b-extension))
 112     `((bottom-group-key-names
 113        . (((x
 114             . ((offset . (-0.45 . -1.05))
 115                (stencil . ,piccolo-rh-x-key-stencil)
 116                (text? . ("X" . #f))
 117                (complexity . trill))))
 118         ((cis
 119           . ((offset . (0.0 . 0.0))
 120             (stencil . ,flute-rh-cis-key-stencil)
 121             (text? . ("C" . 1))
 122             (complexity . trill)))
 123          (c
 124           . ((offset . (0.3 . 0.0))
 125              (stencil . ,flute-rh-c-key-stencil)
 126              (text? . ("C" . #f))
 127              (complexity . trill)))
 128          (gz
 129           . ((offset . (0.0 . -1.2))
 130              (stencil . ,flute-rh-gz-key-stencil)
 131              (text? . ("gz" . #f))
 132              (complexity . trill))))
 133         ((cis
 134           . ((offset . (0.0 . 0.0))
 135             (stencil . ,flute-rh-cis-key-stencil)
 136             (text? . ("C" . 1))
 137             (complexity . trill)))
 138          (c
 139           . ((offset . (0.3 . 0.0))
 140              (stencil . ,flute-rh-c-key-stencil)
 141              (text? . ("C" . #f))
 142              (complexity . trill)))
 143          (b
 144           . ((offset . (1.0 . 0.0))
 145              (stencil . ,flute-rh-b-key-stencil)
 146              (text? . ("B" . #f))
 147              (complexity . trill)))
 148          (gz
 149           . ((offset . (0.0 . -1.2))
 150              (stencil . ,flute-rh-gz-key-stencil)
 151              (text? . ("gz" . #f))
 152              (complexity . trill))))))
 153       (bottom-group-graphical-stencil
 154        . (((right-hand . ees) (right-hand . x))
 155           ,(make-right-hand-key-addresses '(ees cis c gz))
 156           ,(make-right-hand-key-addresses '(ees cis c b gz))))
 157      (bottom-group-graphical-draw-instruction
 158        . (((right-hand . ees))
 159           ,(make-right-hand-key-addresses '(ees cis c))
 160           ,(make-right-hand-key-addresses '(ees cis c b))))
 161      (bottom-group-special-key-instruction
 162       . ((,rich-group-draw-rule ((right-hand . x)) ((right-hand . ees)))
 163          (,rich-group-draw-rule ((right-hand . gz))
 164                                 ,(make-right-hand-key-addresses
 165                                     '(ees cis c)))
 166          (,rich-group-draw-rule ((right-hand . gz))
 167                                 ,(make-right-hand-key-addresses
 168                                     '(ees cis c b)))))
 169      (bottom-group-text-stencil
 170       . (,(make-right-hand-key-addresses '(bes d dis ees x))
 171          ,(make-right-hand-key-addresses '(bes d dis ees cis c gz))
 172          ,(make-right-hand-key-addresses '(bes d dis ees cis c b gz)))))))
 173
 174 (define (generate-flute-family-entry flute-name)
 175   (let*
 176       ((change-points
 177         (get-named-spreadsheet-column
 178           flute-name
 179           flute-change-points)))
 180   `(,flute-name
 181     . ((keys
 182         . ((hidden
 183             . ((midline
 184                 . ((offset . (0.0 . 0.0))
 185                    (stencil . ,midline-stencil)
 186                    (text? . #f)
 187                    (complexity . basic)))))
 188            (central-column
 189             . ((one
 190                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
 191                    (stencil . ,ring-column-circle-stencil)
 192                    (text? . #f)
 193                    (complexity . ring)))
 194                (two
 195                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
 196                    (stencil . ,ring-column-circle-stencil)
 197                    (text? . #f)
 198                    (complexity . ring)))
 199                (three
 200                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
 201                    (stencil . ,ring-column-circle-stencil)
 202                    (text? . #f)
 203                    (complexity . ring)))
 204                (four
 205                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
 206                    (stencil . ,ring-column-circle-stencil)
 207                    (text? . #f)
 208                    (complexity . ring)))
 209                (five
 210                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
 211                    (stencil . ,ring-column-circle-stencil)
 212                    (text? . #f)
 213                    (complexity . ring)))
 214                (six
 215                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
 216                    (stencil . ,ring-column-circle-stencil)
 217                    (text? . #f)
 218                    (complexity . ring)))))
 219            (left-hand
 220             . ((bes
 221                 . ((offset . (0.5 . 1.8))
 222                    (stencil . ,flute-lh-bes-key-stencil)
 223                    (text? . ("B" . 0))
 224                    (complexity . trill)))
 225                (b
 226                 . ((offset . (0.0 . 0.0))
 227                    (stencil . ,flute-lh-b-key-stencil)
 228                    (text? . ("B" . #f))
 229                    (complexity . trill)))
 230                (gis
 231                 . ((offset . (0.0 . 0.0))
 232                    (stencil . ,flute-lh-gis-key-stencil)
 233                    (text? . ("G" . 1))
 234                    (complexity . trill)))))
 235            (right-hand
 236             . ,(append `((bes
 237                           . ((offset . (0.0 . 0.0))
 238                              (stencil . ,flute-rh-bes-key-stencil)
 239                              (text? . ("B" . 0))
 240                              (complexity . trill)))
 241                          (d
 242                           . ((offset . (0.0 . 0.0))
 243                              (stencil . ,flute-rh-d-key-stencil)
 244                              (text? . ("D" . #f))
 245                              (complexity . trill)))
 246                          (dis
 247                           . ((offset . (0.0 . 0.0))
 248                              (stencil . ,flute-rh-dis-key-stencil)
 249                              (text? . ("D" . 1))
 250                              (complexity . trill)))
 251                          (ees
 252                           . ((offset . (1.5 . 1.3))
 253                              (stencil . ,flute-rh-ees-key-stencil)
 254                              (text? . ("E" . 0))
 255                              (complexity . trill))))
 256                        (assoc-get 'bottom-group-key-names change-points)))))
 257        (graphical-commands
 258         . ((stencil-alist
 259             . ((stencils
 260                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 261                    ((stencils
 262                      . ,(make-central-column-hole-addresses
 263                            CENTRAL-COLUMN-HOLE-LIST))
 264                     (xy-scale-function . (,identity . ,identity))
 265                     (textual? . #f)
 266                     (offset . (0.0 . 0.0)))
 267                    ((stencils . ((left-hand . bes) (left-hand . b)))
 268                     (xy-scale-function . (,return-1 . ,return-1))
 269                     (textual? . #f)
 270                     (offset . (-1.5 . 6.5)))
 271                    ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0))
 272                    ,(simple-stencil-alist '(right-hand . bes)  '(-1.75 . 3.05))
 273                    ,(simple-stencil-alist '(right-hand . d)  '(-1.0 . 2.5))
 274                    ,(simple-stencil-alist '(right-hand . dis)  '(-1.0 . 1.5))
 275                    ((stencils
 276                      . ,(assoc-get 'bottom-group-graphical-stencil
 277                                    change-points))
 278                     (xy-scale-function . (,return-1 . ,return-1))
 279                     (textual? . #f)
 280                     (offset . (0.0 . -0.6)))))
 281                (xy-scale-function . (,identity . ,identity))
 282                (textual? . #f)
 283                (offset . (0.0 . 0.0))))
 284            (draw-instructions
 285             . ((,apply-group-draw-rule-series
 286                 (((left-hand . bes) (left-hand . b))
 287                  ,(assoc-get 'bottom-group-graphical-draw-instruction
 288                              change-points)))
 289                ,(assoc-get 'bottom-group-special-key-instruction
 290                            change-points)
 291                (,group-automate-rule
 292                 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 293                (,group-automate-rule ((hidden . midline)))))
 294            (extra-offset-instructions
 295             . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
 296        (text-commands
 297         . ((stencil-alist
 298             . ((stencils
 299                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 300                    ((stencils
 301                      . ,(make-central-column-hole-addresses
 302                            CENTRAL-COLUMN-HOLE-LIST))
 303                     (xy-scale-function . (,identity . ,identity))
 304                     (textual? . #f)
 305                     (offset . (0.0 . 0.0)))
 306                    ((stencils . ,(make-left-hand-key-addresses '(bes b gis)))
 307                     (textual? . ,lh-woodwind-text-stencil)
 308                     (offset . (1.5 . 3.75)))
 309                    ((stencils . ,(assoc-get 'bottom-group-text-stencil
 310                                             change-points))
 311                     (textual? . ,rh-woodwind-text-stencil)
 312                     (offset . (-1.25 . 0.0)))))
 313                (xy-scale-function . (,identity . ,identity))
 314                (textual? . #f)
 315                (offset . (0.0 . 0.0))))
 316            (draw-instructions
 317             . ((,apply-group-draw-rule-series
 318                  (,(make-left-hand-key-addresses '(bes b gis))
 319                   ,(assoc-get 'bottom-group-text-stencil change-points)))
 320                (,group-automate-rule
 321                 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 322                (,group-automate-rule ((hidden . midline)))))
 323            (extra-offset-instructions
 324             . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
 325
 326 ;;; Tin whistle assembly instructions
 327
 328 (define tin-whistle-change-points
 329   ((make-named-spreadsheet '(tin-whistle)) '()))
 330
 331 (define (generate-tin-whistle-family-entry tin-whistle-name)
 332   (let*
 333     ((change-points
 334      (get-named-spreadsheet-column tin-whistle-name tin-whistle-change-points)))
 335   `(,tin-whistle-name
 336     . ((keys
 337         . ((hidden
 338             . ((midline
 339                 . ((offset . (0.0 . 0.0))
 340                    (stencil . ,midline-stencil)
 341                    (text? . #f)
 342                    (complexity . basic)))))
 343            (central-column
 344             . ((one
 345                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
 346                    (stencil . ,column-circle-stencil)
 347                    (text? . #f)
 348                    (complexity . covered)))
 349                (two
 350                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
 351                    (stencil . ,column-circle-stencil)
 352                    (text? . #f)
 353                    (complexity . covered)))
 354                (three
 355                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
 356                    (stencil . ,column-circle-stencil)
 357                    (text? . #f)
 358                    (complexity . covered)))
 359                (four
 360                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
 361                    (stencil . ,column-circle-stencil)
 362                    (text? . #f)
 363                    (complexity . covered)))
 364                (five
 365                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
 366                    (stencil . ,column-circle-stencil)
 367                    (text? . #f)
 368                    (complexity . covered)))
 369                (six
 370                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
 371                    (stencil . ,column-circle-stencil)
 372                    (text? . #f)
 373                    (complexity . covered)))))
 374            (left-hand . ())
 375            (right-hand . ())))
 376        (graphical-commands
 377         . ((stencil-alist
 378             . ((stencils
 379                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 380                    ((stencils
 381                      . ,(make-central-column-hole-addresses
 382                           CENTRAL-COLUMN-HOLE-LIST))
 383                     (xy-scale-function . (,identity . ,identity))
 384                     (textual? . #f)
 385                     (offset . (0.0 . 0.0)))))
 386                (xy-scale-function . (,identity . ,identity))
 387                (textual? . #f)
 388                (offset . (0.0 . 0.0))))
 389            (draw-instructions
 390             . ((,group-automate-rule
 391                  ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 392                (,group-automate-rule ((hidden . midline)))))
 393            (extra-offset-instructions
 394             . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
 395     (text-commands
 396      . ((stencil-alist
 397          . ((stencils .
 398              (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 399               ((stencils
 400                 . ,(make-central-column-hole-addresses
 401                       CENTRAL-COLUMN-HOLE-H-LIST))
 402                (xy-scale-function . (,identity . ,identity))
 403                (textual? . #f)
 404                (offset . (0.0 . 0.0)))))
 405             (xy-scale-function . (,identity . ,identity))
 406             (textual? . #f)
 407             (offset . (0.0 . 0.0))))
 408         (draw-instructions
 409          . ((,group-automate-rule
 410               ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 411             (,group-automate-rule ((hidden . midline)))))
 412         (extra-offset-instructions
 413          . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
 414
 415 ;;; Oboe assembly instructions
 416
 417 (define oboe-change-points
 418   ((make-named-spreadsheet '(oboe)) '()))
 419
 420 (define (generate-oboe-family-entry oboe-name)
 421   (let*
 422     ((change-points
 423      (get-named-spreadsheet-column oboe-name oboe-change-points)))
 424   `(,oboe-name
 425     . ((keys
 426         . ((hidden
 427             . ((midline
 428                 . ((offset . (0.0 . 0.0))
 429                    (stencil . ,midline-stencil)
 430                    (text? . #f)
 431                    (complexity . basic)))))
 432            (central-column
 433             . ((one
 434                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
 435                    (stencil . ,ring-column-circle-stencil)
 436                    (text? . #f)
 437                    (complexity . ring)))
 438                (two
 439                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
 440                    (stencil . ,ring-column-circle-stencil)
 441                    (text? . #f)
 442                    (complexity . ring)))
 443                (three
 444                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
 445                    (stencil . ,ring-column-circle-stencil)
 446                    (text? . #f)
 447                    (complexity . ring)))
 448                (four
 449                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
 450                    (stencil . ,ring-column-circle-stencil)
 451                    (text? . #f)
 452                    (complexity . ring)))
 453                (five
 454                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
 455                    (stencil . ,ring-column-circle-stencil)
 456                    (text? . #f)
 457                    (complexity . ring)))
 458                (six
 459                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
 460                    (stencil . ,ring-column-circle-stencil)
 461                    (text? . #f)
 462                    (complexity . ring)))
 463                (h
 464                 . ((offset . (0.0 . 6.25))
 465                    (stencil . ,(variable-column-circle-stencil 0.4))
 466                    (text? . #f)
 467                    (complexity . trill)))))
 468            (left-hand
 469             . ((I
 470                 . ((offset . (0.0 . 0.0))
 471                    (stencil . ,oboe-lh-I-key-stencil)
 472                    (text? . ("I" . #f))
 473                    (complexity . trill)))
 474                (III
 475                 . ((offset . (0.0 . 2.6))
 476                    (stencil . ,oboe-lh-III-key-stencil)
 477                    (text? . ("III" . #f))
 478                    (complexity . trill)))
 479                (II
 480                 . ((offset . (0.0 . 0.0))
 481                    (stencil . ,oboe-lh-II-key-stencil)
 482                    (text? . ("II" . #f))
 483                    (complexity . trill)))
 484                (b
 485                 . ((offset . (0.0 . 0.0))
 486                    (stencil . ,oboe-lh-b-key-stencil)
 487                    (text? . ("B" . #f))
 488                    (complexity . trill)))
 489                (d
 490                 . ((offset . (0.0 . 0.0))
 491                    (stencil . ,oboe-lh-d-key-stencil)
 492                    (text? . ("D" . #f))
 493                    (complexity . trill)))
 494                (cis
 495                 . ((offset . (0.0 . 0.0))
 496                    (stencil . ,oboe-lh-cis-key-stencil)
 497                    (text? . ("C" . 1))
 498                    (complexity . trill)))
 499                (gis
 500                 . ((offset . (-0.85 . 0.2))
 501                    (stencil . ,oboe-lh-gis-key-stencil)
 502                    (text? . ("G" . 1))
 503                    (complexity . trill)))
 504                (ees
 505                 . ((offset . (2.05 . -3.65))
 506                    (stencil . ,oboe-lh-ees-key-stencil)
 507                    (text? . ("E" . 0))
 508                    (complexity . trill)))
 509                (low-b
 510                 . ((offset . (3.6 . 0.5))
 511                    (stencil . ,oboe-lh-low-b-key-stencil)
 512                    (text? . ("b" . #f))
 513                    (complexity . trill)))
 514                (bes
 515                 . ((offset . (2.25 . -4.15))
 516                    (stencil . ,oboe-lh-bes-key-stencil)
 517                    (text? . ("B" . 0))
 518                    (complexity . trill)))
 519                (f
 520                 . ((offset . (2.15 . -3.85))
 521                    (stencil . ,oboe-lh-f-key-stencil)
 522                    (text? . ("F" . #f))
 523                    (complexity . trill)))))
 524            (right-hand
 525             . ((a
 526                 . ((offset . (1.5 . 1.2))
 527                    (stencil . ,oboe-rh-a-key-stencil)
 528                    (text? . ("A" . #f))
 529                    (complexity . trill)))
 530                (gis
 531                 . ((offset . (0.0 . 0.0))
 532                    (stencil . ,oboe-rh-gis-key-stencil)
 533                    (text? . ("G" . 1))
 534                    (complexity . trill)))
 535                (d
 536                 . ((offset . (0.0 . 0.0))
 537                    (stencil . ,oboe-rh-d-key-stencil)
 538                    (text? . ("D" . #f))
 539                    (complexity . trill)))
 540                (f
 541                 . ((offset . (0.0 . 0.0))
 542                    (stencil . ,oboe-rh-f-key-stencil)
 543                    (text? . ("F" . #f))
 544                    (complexity . trill)))
 545                (banana
 546                 . ((offset . (0.0 . 0.0))
 547                    (stencil . ,oboe-rh-banana-key-stencil)
 548                    (text? . ("ban" . #f))
 549                    (complexity . trill)))
 550                (c
 551                 . ((offset . (0.0 . 0.0))
 552                    (stencil . ,oboe-rh-c-key-stencil)
 553                    (text? . ("C" . #f))
 554                    (complexity . trill)))
 555                (cis
 556                 . ((offset . (3.8 . -0.6))
 557                    (stencil . ,oboe-rh-cis-key-stencil)
 558                    (text? . ("C" . 1))
 559                    (complexity . trill)))
 560                (ees
 561                 . ((offset . (0.0 . -1.8))
 562                    (stencil . ,oboe-rh-ees-key-stencil)
 563                    (text? . ("E" . 0))
 564                    (complexity . trill)))))))
 565        (graphical-commands
 566         . ((stencil-alist
 567             . ((stencils
 568                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 569                    ((stencils
 570                      . ,(make-central-column-hole-addresses
 571                           CENTRAL-COLUMN-HOLE-H-LIST))
 572                     (xy-scale-function . (,identity . ,identity))
 573                     (textual? . #f)
 574                     (offset . (0.0 . 0.0)))
 575                    ((stencils . ((left-hand . I) (left-hand . III)))
 576                     (xy-scale-function . (,return-1 . ,return-1))
 577                     (textual? . #f)
 578                     (offset . (-2.5 . 6.5)))
 579                    ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0))
 580                    ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0))
 581                    ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0))
 582                    ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0))
 583                    ((stencils
 584                      . ,(make-left-hand-key-addresses '(gis bes low-b ees f)))
 585                     (xy-scale-function . (,return-1 . ,return-1))
 586                     (textual? . #f)
 587                     (offset . (0.0 . 3.9)))
 588                    ((stencils .
 589                     ,(make-right-hand-key-addresses '(a gis)))
 590                     (xy-scale-function . (,return-1 . ,return-1))
 591                     (textual? . #f)
 592                     (offset . (-3.5 . 3.5)))
 593                    ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5))
 594                    ,(simple-stencil-alist '(right-hand . f)  '(-1.0 . 1.5))
 595                    ,(simple-stencil-alist '(right-hand . banana)  '(1.7 . 1.0))
 596                    ((stencils . ,(make-right-hand-key-addresses '(c cis ees)))
 597                     (xy-scale-function . (,return-1 . ,return-1))
 598                     (textual? . #f)
 599                     (offset . (-3.4 . 0.3)))))
 600                (xy-scale-function . (,identity . ,identity))
 601                (textual? . #f)
 602                (offset . (0.0 . 0.0))))
 603            (draw-instructions
 604             . ((,apply-group-draw-rule-series
 605                  (((right-hand . a) (right-hand . gis))
 606                   ,(make-left-hand-key-addresses '(gis bes low-b ees))
 607                   ,(make-right-hand-key-addresses '(cis c ees))))
 608                (,rich-group-draw-rule
 609                  ((left-hand . III))
 610                  ((left-hand . I)))
 611                (,rich-group-draw-rule
 612                  ((left-hand . f))
 613                  ,(make-left-hand-key-addresses '(gis bes low-b ees)))
 614                (,group-automate-rule
 615                  ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 616                (,group-automate-rule ((hidden . midline)))))
 617            (extra-offset-instructions
 618             . ((,rich-group-extra-offset-rule
 619                  ((central-column . h)) ((central-column . one)) (0.0 . 0.8))
 620                (,uniform-extra-offset-rule (0.0 . 0.0))))))
 621     (text-commands
 622      . ((stencil-alist
 623          . ((stencils .
 624              (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 625               ((stencils
 626                 . ,(make-central-column-hole-addresses
 627                       CENTRAL-COLUMN-HOLE-H-LIST))
 628                (xy-scale-function . (,identity . ,identity))
 629                (textual? . #f)
 630                (offset . (0.0 . 0.0)))
 631               ((stencils . ,(make-left-hand-key-addresses '(III I)))
 632                (textual? . ,lh-woodwind-text-stencil)
 633                (offset . (-2.8 . 7.0)))
 634               ((stencils . ,(make-left-hand-key-addresses '(II)))
 635                (textual? . ,lh-woodwind-text-stencil)
 636                (offset . (2.2 . 7.0)))
 637               ((stencils
 638                 .  ,(make-left-hand-key-addresses
 639                       '(b d cis gis ees low-b bes f)))
 640                (textual? . ,lh-woodwind-text-stencil)
 641                (offset . (1.5 . 3.75)))
 642               ((stencils
 643                 . ,(make-right-hand-key-addresses
 644                       '(a gis d f banana c cis ees)))
 645                (textual? . ,rh-woodwind-text-stencil)
 646                (offset . (-1.25 . 0.0)))))
 647             (xy-scale-function . (,identity . ,identity))
 648             (textual? . #f)
 649             (offset . (0.0 . 0.0))))
 650         (draw-instructions
 651          . ((,apply-group-draw-rule-series
 652               (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f))
 653              ,(make-left-hand-key-addresses '(III I))
 654              ,(make-right-hand-key-addresses '(a gis d f banana c cis ees))))
 655             (,group-automate-rule
 656               ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
 657             (,group-automate-rule ((hidden . midline)))))
 658         (extra-offset-instructions
 659          . ((,rich-group-extra-offset-rule
 660               ((central-column . h))
 661               ((central-column . one))
 662               (0.0 . 0.8))
 663             (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
 664
 665 ;; Clarinet assembly instructions
 666
 667 (define clarinet-change-points
 668   ((make-named-spreadsheet '(clarinet bass-clarinet low-bass-clarinet))
 669     `((bottom-group-key-names
 670        . (()
 671           ((ees
 672             . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
 673                (stencil . ,bass-clarinet-rh-ees-key-stencil)
 674                (text? . ("E" . 0))
 675                (complexity . trill))))
 676           ((ees
 677             . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
 678                (stencil . ,low-bass-clarinet-rh-ees-key-stencil)
 679                (text? . ("E" . 0))
 680                (complexity . trill)))
 681            (d
 682             . ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* -1 (+ 0.75 CL-RH-HAIR))))
 683                (stencil . ,clarinet-rh-d-key-stencil)
 684                (text? . ("d" . #f))
 685                (complexity . trill)))
 686            (low-cis
 687             . ((offset . (0.0 . 1.4))
 688                (stencil . ,clarinet-rh-low-cis-key-stencil)
 689                (text? . ("c" . 1))
 690                (complexity . trill)))
 691            (low-d
 692             . ((offset . (0.0 . 2.4))
 693                (stencil . ,clarinet-rh-low-d-key-stencil)
 694                (text? . ("d" . #f))
 695                (complexity . trill)))
 696            (low-c
 697             . ((offset . (0.0 . 0.0))
 698                (stencil . ,clarinet-rh-low-c-key-stencil)
 699                (text? . ("c" . #f))
 700                (complexity . trill))))))
 701       (left-extra-key-names
 702        . (()
 703           ()
 704           ((d
 705             . ((offset . (4.0 . -0.8))
 706                (stencil . ,clarinet-lh-d-key-stencil)
 707                (text? . ("D" . #f))
 708                (complexity . trill))))))
 709       (right-thumb-group
 710        . (()
 711           ()
 712           (((stencils
 713             . ,(make-right-hand-key-addresses '(low-c low-cis)))
 714            (xy-scale-function . (,return-1 . ,return-1))
 715            (textual? . #f)
 716            (offset . (-1.3 . 4.0))))))
 717       (low-left-hand-key-addresses
 718        . (,(make-left-hand-key-addresses '(cis f e fis))
 719           ,(make-left-hand-key-addresses '(cis f e fis))
 720           ,(make-left-hand-key-addresses '(cis f e fis d))))
 721       (all-left-hand-key-addresses
 722        . (,(make-left-hand-key-addresses '(a gis ees cis f e fis))
 723           ,(make-left-hand-key-addresses '(a gis ees cis f e fis))
 724           ,(make-left-hand-key-addresses '(a gis ees cis f e fis d))))
 725       (low-key-group
 726        . (()
 727           ()
 728           (,(make-right-hand-key-addresses '(low-c low-cis)))))
 729       (low-rich-draw-rules
 730        . (()
 731           ()
 732           ((,rich-group-draw-rule
 733                   ((left-hand . d))
 734                   ,(make-left-hand-key-addresses '(cis f e fis)))
 735            (,rich-group-draw-rule
 736                   ((right-hand . low-d))
 737                   ((right-hand . low-cis) (right-hand . low-c))))))
 738       (low-extra-offset-rule
 739        . (()
 740           ()
 741           ((,rich-group-extra-offset-rule
 742                  ,(make-right-hand-key-addresses '(low-c low-d low-cis))
 743                  ,(make-right-hand-key-addresses '(one two three four))
 744                  (-0.5 . -0.7)))))
 745       (bottom-right-group-key-addresses
 746        . (,(make-right-hand-key-addresses '(fis e f gis))
 747           ,(make-right-hand-key-addresses '(fis e ees gis f))
 748           ,(make-right-hand-key-addresses '(fis e ees gis f d))))
 749       (right-hand-key-addresses
 750        . (,(make-right-hand-key-addresses '(fis e f gis))
 751           ,(make-right-hand-key-addresses '(fis e ees gis f))
 752           ,(make-right-hand-key-addresses
 753               '(low-d low-cis low-c fis e ees gis f d)))))))
 754
 755 (define (generate-clarinet-family-entry clarinet-name)
 756   (let*
 757     ((change-points
 758       (get-named-spreadsheet-column clarinet-name clarinet-change-points)))
 759   `(,clarinet-name
 760     . ((keys
 761         . ((hidden
 762             . ((midline
 763                 . ((offset . (0.0 . 0.0))
 764                    (stencil . ,midline-stencil)
 765                    (text? . #f)
 766                    (complexity . basic)))))
 767            (central-column
 768             . ((one
 769                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
 770                    (stencil . ,column-circle-stencil)
 771                    (text? . #f)
 772                    (complexity . covered)))
 773                (two
 774                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
 775                    (stencil . ,column-circle-stencil)
 776                    (text? . #f)
 777                    (complexity . covered)))
 778                (three
 779                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
 780                    (stencil . ,column-circle-stencil)
 781                    (text? . #f)
 782                    (complexity . covered)))
 783                (four
 784                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
 785                    (stencil . ,column-circle-stencil)
 786                    (text? . #f)
 787                    (complexity . covered)))
 788                (five
 789                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
 790                    (stencil . ,column-circle-stencil)
 791                    (text? . #f)
 792                    (complexity . covered)))
 793                (six
 794                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
 795                    (stencil . ,column-circle-stencil)
 796                    (text? . #f)
 797                    (complexity . covered)))
 798                (h
 799                 . ((offset . (0.0 . 6.25))
 800                    (stencil . ,(variable-column-circle-stencil 0.4))
 801                    (text? . #f)
 802                    (complexity . covered)))))
 803            (left-hand
 804             . ,(append `((thumb
 805                           . ((offset . (0.0 . 0.0))
 806                              (stencil . ,clarinet-lh-thumb-key-stencil)
 807                              (text? . #f)
 808                              (complexity . trill)))
 809                          (R
 810                           . ((offset . (1.0 . 1.0))
 811                              (stencil . ,clarinet-lh-R-key-stencil)
 812                              (text? . #f)
 813                              (complexity . trill)))
 814                          (a
 815                           . ((offset . (0.0 . 0.0))
 816                              (stencil . ,clarinet-lh-a-key-stencil)
 817                              (text? . ("A" . #f))
 818                              (complexity . trill)))
 819                          (gis
 820                           . ((offset . (0.8 . 1.0))
 821                              (stencil . ,clarinet-lh-gis-key-stencil)
 822                              (text? . ("G" . 1))
 823                              (complexity . trill)))
 824                          (ees
 825                           . ((offset . (0.0 . 0.0))
 826                              (stencil . ,clarinet-lh-ees-key-stencil)
 827                              (text? . ("E" . 0))
 828                              (complexity . trill)))
 829                          (cis
 830                           . ((offset . (-0.85 . 0.2))
 831                              (stencil . ,clarinet-lh-cis-key-stencil)
 832                              (text? . ("C" . 1))
 833                              (complexity . trill)))
 834                          (f
 835                           . ((offset . (3.6 . 0.5))
 836                              (stencil . ,clarinet-lh-f-key-stencil)
 837                              (text? . ("F" . #f))
 838                              (complexity . trill)))
 839                          (e
 840                           . ((offset . (2.05 . -3.65))
 841                              (stencil . ,clarinet-lh-e-key-stencil)
 842                              (text? . ("E" . #f))
 843                              (complexity . trill)))
 844                          (fis
 845                           . ((offset . (2.25 . -4.15))
 846                              (stencil . ,clarinet-lh-fis-key-stencil)
 847                              (text? . ("F" . 1))
 848                              (complexity . trill))))
 849                         (assoc-get 'left-extra-key-names change-points)))
 850            (right-hand
 851             . ,(append `((one
 852                           . ((offset . (0.0 . 0.75))
 853                              (stencil . ,clarinet-rh-one-key-stencil)
 854                              (text? . "1")
 855                              (complexity . trill)))
 856                          (two
 857                           . ((offset . (0.0 . 0.25))
 858                              (stencil . ,clarinet-rh-two-key-stencil)
 859                              (text? . "2")
 860                              (complexity . trill)))
 861                          (three
 862                           . ((offset . (0.0 . -0.25))
 863                              (stencil . ,clarinet-rh-three-key-stencil)
 864                              (text? . "3")
 865                              (complexity . trill)))
 866                          (four
 867                           . ((offset . (0.0 . -0.75))
 868                              (stencil . ,clarinet-rh-four-key-stencil)
 869                              (text? . "4")
 870                              (complexity . trill)))
 871                          (b
 872                           . ((offset . (0.0 . 0.0))
 873                              (stencil . ,clarinet-rh-b-key-stencil)
 874                              (text? . ("B" . #f))
 875                              (complexity . trill)))
 876                          (fis
 877                           . ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR))))
 878                              (stencil . ,clarinet-rh-fis-key-stencil)
 879                              (text? . ("F" . 1))
 880                              (complexity . trill)))
 881                          (gis
 882                           . ((offset . (,(+ 1.5 CL-RH-HAIR)
 883                                         . ,(* 3 (+ 0.75 CL-RH-HAIR))))
 884                              (stencil . ,clarinet-rh-gis-key-stencil)
 885                              (text? . ("G" . 1))
 886                              (complexity . trill)))
 887                          (e
 888                           . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR))))
 889                              (stencil . ,clarinet-rh-e-key-stencil)
 890                              (text? . ("E" . #f))
 891                              (complexity . trill)))
 892                          (f
 893                           . ((offset . (,(+ 1.5 CL-RH-HAIR)
 894                                         . ,(* 1 (+ 0.75 CL-RH-HAIR))))
 895                              (stencil . ,clarinet-rh-f-key-stencil)
 896                              (text? . ("F" . #f))
 897                              (complexity . trill))))
 898                        (assoc-get 'bottom-group-key-names change-points)))))
 899        (graphical-commands
 900         . ((stencil-alist
 901             . ((stencils
 902                 . ,(append (assoc-get 'right-thumb-group change-points)
 903                            `(,(simple-stencil-alist '(hidden . midline)
 904                                                     '(0.0 . 3.75))
 905                             ((stencils
 906                               . ,(make-central-column-hole-addresses
 907                                    CENTRAL-COLUMN-HOLE-H-LIST))
 908                              (xy-scale-function . (,identity . ,identity))
 909                              (textual? . #f)
 910                              (offset . (0.0 . 0.0)))
 911                             ((stencils
 912                               . ,(make-left-hand-key-addresses '(thumb R)))
 913                              (xy-scale-function . (,identity . ,identity))
 914                              (textual? . #f)
 915                              (offset . (-2.5 . 6.5)))
 916                             ((stencils
 917                               . ((left-hand . a) (left-hand . gis)))
 918                              (xy-scale-function . (,return-1 . ,return-1))
 919                              (textual? . #f)
 920                              (offset . (0.0 . 7.5)))
 921                             ,(simple-stencil-alist '(left-hand . ees)
 922                                                    '(1.0 . 5.0))
 923                             ((stencils
 924                               . ,(make-left-hand-key-addresses '(cis f e fis)))
 925                              (xy-scale-function . (,return-1 . ,return-1))
 926                              (textual? . #f)
 927                              (offset . (0.0 . 3.9)))
 928                             ((stencils
 929                               . ,(make-right-hand-key-addresses
 930                                     '(one two three four)))
 931                              (xy-scale-function . (,return-1 . ,return-1))
 932                              (textual? . #f)
 933                              (offset . (-1.25 . 3.75)))
 934                             ,(simple-stencil-alist '(right-hand . b)
 935                                                    '(-1.0 . 1.5))
 936                             ((stencils
 937                               . ,(assoc-get 'bottom-right-group-key-addresses
 938                                             change-points))
 939                              (xy-scale-function . (,return-1 . ,return-1))
 940                              (textual? . #f)
 941                              (offset . (-4.0 . -0.75))))))
 942                (xy-scale-function . (,identity . ,identity))
 943                (textual? . #f)
 944                (offset . (0.0 . 0.0))))
 945            (draw-instructions
 946             . ,(append (assoc-get 'low-rich-draw-rules change-points)
 947                        `((,apply-group-draw-rule-series
 948                           ,(append (assoc-get 'low-key-group change-points)
 949                                    `(((left-hand . a) (left-hand . gis))
 950                                      ,(make-right-hand-key-addresses
 951                                          '(one two three four))
 952                                      ,(assoc-get 'low-left-hand-key-addresses
 953                                                  change-points)
 954                                      ,(assoc-get 'right-hand-key-addresses
 955                                                  change-points))))
 956                         (,rich-group-draw-rule
 957                            ((left-hand . R))
 958                            ((left-hand . thumb)))
 959                         (,group-automate-rule
 960                            ,(make-central-column-hole-addresses
 961                                CENTRAL-COLUMN-HOLE-LIST))
 962                         (,group-automate-rule ((hidden . midline))))))
 963            (extra-offset-instructions
 964             . ,(append (assoc-get 'low-extra-offset-rule change-points)
 965                        `((,rich-group-extra-offset-rule
 966                           ((central-column . h))
 967                           ((central-column . one)
 968                            (left-hand . a)
 969                            (left-hand . gis))
 970                           (0.0 . 0.8))
 971                          (,uniform-extra-offset-rule (0.0 . 0.0)))))))
 972        (text-commands
 973         . ((stencil-alist
 974             . ((stencils
 975                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
 976                    ((stencils
 977                      . ,(make-central-column-hole-addresses
 978                            CENTRAL-COLUMN-HOLE-LIST))
 979                     (xy-scale-function . (,identity . ,identity))
 980                     (textual? . #f)
 981                     (offset . (0.0 . 0.0)))
 982                    ((stencils . ((left-hand . thumb) (left-hand . R)))
 983                     (xy-scale-function . (,identity . ,identity))
 984                     (textual? . #f)
 985                     (offset . (-2.5 . 6.5)))
 986                    ((stencils
 987                      . ,(assoc-get 'all-left-hand-key-addresses change-points))
 988                     (textual? . ,lh-woodwind-text-stencil)
 989                     (offset . (1.5 . 3.75)))
 990                    ((stencils
 991                      . ,(make-right-hand-key-addresses '(one two three four)))
 992                     (textual? . ,number-column-stencil)
 993                     (offset . (-1.25 . 3.75)))
 994                    ((stencils . ,(assoc-get 'right-hand-key-addresses
 995                                             change-points))
 996                     (textual? . ,rh-woodwind-text-stencil)
 997                     (offset . (-1.25 . 0.0)))))
 998                (xy-scale-function . (,identity . ,identity))
 999                (textual? . #f)
1000                (offset . (0.0 . 0.0))))
1001            (draw-instructions
1002             . ((,apply-group-draw-rule-series
1003                  (,(assoc-get 'all-left-hand-key-addresses change-points)
1004                   ,(make-right-hand-key-addresses '(one two three four))
1005                   ,(assoc-get 'right-hand-key-addresses change-points)))
1006                (,group-automate-rule
1007                  ,(make-central-column-hole-addresses
1008                      CENTRAL-COLUMN-HOLE-LIST))
1009                (,group-automate-rule ((hidden . midline)))))
1010            (extra-offset-instructions
1011             . ((,rich-group-extra-offset-rule
1012                   ((central-column . h))
1013                   ((central-column . one) (left-hand . a) (left-hand . gis))
1014                   (0.0 . 0.8))
1015                (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1016
1017 ;; Saxophone assembly instructions
1018
1019 (define (saxophone-name-passerelle name)
1020   (cond ((eqv? name 'saxophone) 'saxophone)
1021         ((eqv? name 'soprano-saxophone) 'saxophone)
1022         ((eqv? name 'alto-saxophone) 'saxophone)
1023         ((eqv? name 'tenor-saxophone) 'saxophone)
1024         ((eqv? name 'baritone-saxophone) 'baritone-saxophone)))
1025
1026 (define saxophone-change-points
1027   ((make-named-spreadsheet '(saxophone baritone-saxophone))
1028     `((low-a-key-definition
1029        . (()
1030           ((low-a
1031             . ((offset . (0.0 . 0.0))
1032                (stencil . ,saxophone-lh-low-a-key-stencil)
1033                (text? . #f)
1034                (complexity . trill))))))
1035      (low-a-key-group
1036        . (()
1037           (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0)))))
1038      (low-a-presence
1039        . (()
1040           ((left-hand . low-a))))
1041      (left-hand-key-names
1042        . (,(make-right-hand-key-addresses
1043               '(ees d f front-f bes gis cis b low-bes))
1044           ,(make-right-hand-key-addresses
1045               '(ees d f front-f bes gis cis b low-bes low-a)))))))
1046
1047 (define (generate-saxophone-family-entry saxophone-name)
1048   (let*
1049     ((change-points
1050      (get-named-spreadsheet-column
1051        (saxophone-name-passerelle saxophone-name) saxophone-change-points)))
1052   `(,saxophone-name
1053     . ((keys
1054         . ((hidden
1055             . ((midline
1056                 . ((offset . (0.0 . 0.0))
1057                    (stencil . ,midline-stencil)
1058                    (text? . #f)
1059                    (complexity . basic)))))
1060            (central-column
1061             . ((one
1062                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
1063                    (stencil . ,column-circle-stencil)
1064                    (text? . #f)
1065                    (complexity . trill)))
1066                (two
1067                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
1068                    (stencil . ,column-circle-stencil)
1069                    (text? . #f)
1070                    (complexity . trill)))
1071                (three
1072                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
1073                    (stencil . ,column-circle-stencil)
1074                    (text? . #f)
1075                    (complexity . trill)))
1076                (four
1077                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
1078                    (stencil . ,column-circle-stencil)
1079                    (text? . #f)
1080                    (complexity . trill)))
1081                (five
1082                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
1083                    (stencil . ,column-circle-stencil)
1084                    (text? . #f)
1085                    (complexity . trill)))
1086                (six
1087                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
1088                    (stencil . ,column-circle-stencil)
1089                    (text? . #f)
1090                    (complexity . trill)))))
1091            (left-hand
1092             . ,(append (assoc-get 'low-a-key-definition change-points)
1093                        `((T
1094                           . ((offset . (0.0 . 0.0))
1095                              (stencil . ,saxophone-lh-T-key-stencil)
1096                              (text? . ("T" . #f))
1097                              (complexity . trill)))
1098                          (ees
1099                           . ((offset . (0.4 . 1.6))
1100                              (stencil . ,saxophone-lh-ees-key-stencil)
1101                              (text? . ("E" . 0))
1102                              (complexity . trill)))
1103                          (d
1104                           . ((offset . (1.5 . 0.5))
1105                              (stencil . ,saxophone-lh-d-key-stencil)
1106                              (text? . ("D" . #f))
1107                              (complexity . trill)))
1108                          (f
1109                           . ((offset . (0.0 . 0.0))
1110                              (stencil . ,saxophone-lh-f-key-stencil)
1111                              (text? . ("F" . #f))
1112                              (complexity . trill)))
1113                          (front-f
1114                           . ((offset . (0.0 . 0.0))
1115                              (stencil . ,saxophone-lh-front-f-key-stencil)
1116                              (text? . ("f" . #f))
1117                              (complexity . trill)))
1118                          (bes
1119                           . ((offset . (0.0 . 0.0))
1120                              (stencil . ,saxophone-lh-bes-key-stencil)
1121                              (text? . ("B" . 0))
1122                              (complexity . trill)))
1123                          (gis
1124                           . ((offset . (0.0 . 1.1))
1125                              (stencil . ,saxophone-lh-gis-key-stencil)
1126                              (text? . ("G" . 1))
1127                              (complexity . trill)))
1128                          (cis
1129                           . ((offset . (2.4 . 0.0))
1130                              (stencil . ,saxophone-lh-cis-key-stencil)
1131                              (text? . ("C" . 1))
1132                              (complexity . trill)))
1133                          (b
1134                           . ((offset . (0.0 . 0.0))
1135                             (stencil . ,saxophone-lh-b-key-stencil)
1136                             (text? . ("B" . #f))
1137                             (complexity . trill)))
1138                          (low-bes
1139                           . ((offset . (0.0 . -0.2))
1140                              (stencil . ,saxophone-lh-low-bes-key-stencil)
1141                              (text? . ("b" . 0))
1142                              (complexity . trill))))))
1143            (right-hand
1144             . ((e
1145                 . ((offset . (0.0 . 2.0))
1146                    (stencil . ,saxophone-rh-e-key-stencil)
1147                    (text? . ("E" . #f))
1148                    (complexity . trill)))
1149                (c
1150                 . ((offset . (0.0 . 0.9))
1151                    (stencil . ,saxophone-rh-c-key-stencil)
1152                    (text? . ("C" . #f))
1153                    (complexity . trill)))
1154                (bes
1155                 . ((offset . (0.0 . 0.0))
1156                    (stencil . ,saxophone-rh-bes-key-stencil)
1157                    (text? . ("B" . 0))
1158                    (complexity . trill)))
1159                (high-fis
1160                 . ((offset . (0.0 . 0.0))
1161                    (stencil . ,saxophone-rh-high-fis-key-stencil)
1162                    (text? . ("hF" . 1))
1163                    (complexity . trill)))
1164                (fis
1165                 . ((offset . (0.0 . 0.0))
1166                    (stencil . ,saxophone-rh-fis-key-stencil)
1167                    (text? . ("F" . 1))
1168                    (complexity . trill)))
1169                (ees
1170                 . ((offset . (0.0 . 0.7))
1171                    (stencil . ,saxophone-rh-ees-key-stencil)
1172                    (text? . ("E" . 0))
1173                    (complexity . trill)))
1174                (low-c
1175                 . ((offset . (-1.2 . -0.1))
1176                    (stencil . ,saxophone-rh-low-c-key-stencil)
1177                    (text? . ("c" . #f))
1178                    (complexity . trill)))))))
1179       (graphical-commands
1180        . ((stencil-alist
1181            . ((stencils
1182                . ,(append (assoc-get 'low-a-key-group change-points)
1183                           `(,(simple-stencil-alist '(hidden . midline)
1184                                                    '(0.0 . 3.75))
1185                             ((stencils
1186                               . ,(make-central-column-hole-addresses
1187                                     CENTRAL-COLUMN-HOLE-LIST))
1188                              (xy-scale-function . (,identity . ,identity))
1189                              (textual? . #f)
1190                              (offset . (0.0 . 0.0)))
1191                             ((stencils
1192                               . ,(make-left-hand-key-addresses '(ees d f)))
1193                              (xy-scale-function . (,return-1 . ,return-1))
1194                              (textual? . #f)
1195                              (offset . (1.5 . 6.8)))
1196                             ,(simple-stencil-alist '(left-hand . front-f)
1197                                                    '(0.0 . 7.35))
1198                             ,(simple-stencil-alist '(left-hand . T)
1199                                                    '(-2.2 . 6.5))
1200                             ,(simple-stencil-alist '(left-hand . bes)
1201                                                    '(0.0 . 6.2))
1202                             ((stencils
1203                               . ,(make-left-hand-key-addresses
1204                                     '(gis cis b low-bes)))
1205                              (xy-scale-function . (,return-1 . ,return-1))
1206                              (textual? . #f)
1207                              (offset . (1.2 . 3.5)))
1208                             ((stencils
1209                               . ,(make-right-hand-key-addresses '(e c bes)))
1210                              (xy-scale-function . (,return-1 . ,return-1))
1211                              (textual? . #f)
1212                              (offset . (-2.3 . 3.4)))
1213                             ,(simple-stencil-alist '(right-hand . high-fis)
1214                                                    '(-1.8 . 2.5))
1215                             ,(simple-stencil-alist '(right-hand . fis)
1216                                                    '(-1.5 . 1.5))
1217                             ((stencils
1218                               . ,(make-right-hand-key-addresses '(ees low-c)))
1219                              (xy-scale-function . (,return-1 . ,return-1))
1220                              (textual? . #f)
1221                              (offset . (-2.0 . 0.3))))))
1222               (xy-scale-function . (,identity . ,identity))
1223               (textual? . #f)
1224               (offset . (0.0 . 0.0))))
1225           (draw-instructions
1226            . ((,apply-group-draw-rule-series
1227                 (,(make-left-hand-key-addresses '(ees d f))
1228                  ,(make-left-hand-key-addresses '(gis cis b low-bes))
1229                  ,(make-right-hand-key-addresses '(e c bes))
1230                  ,(make-right-hand-key-addresses '(ees low-c))))
1231               (,group-automate-rule
1232                 ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
1233               (,group-automate-rule ((hidden . midline)))))
1234           (extra-offset-instructions
1235            . ((,rich-group-extra-offset-rule
1236                 ((left-hand . bes))
1237                 ,(append (assoc-get 'low-a-presence change-points)
1238                          '((central-column . one)
1239                            (left-hand . front-f)
1240                            (left-hand . T)
1241                            (left-hand . ees)
1242                            (left-hand . d)
1243                            (left-hand . f)))
1244                 (0.0 . 1.0))
1245               (,uniform-extra-offset-rule (0.0 . 0.0))))))
1246       (text-commands
1247        . ((stencil-alist
1248            . ((stencils
1249                . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
1250                   ((stencils
1251                     . ,(make-central-column-hole-addresses
1252                           CENTRAL-COLUMN-HOLE-LIST))
1253                    (xy-scale-function . (,identity . ,identity))
1254                    (textual? . #f)
1255                    (offset . (0.0 . 0.0)))
1256                   ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0))
1257                   ((stencils
1258                     . ,(assoc-get 'left-hand-key-names change-points))
1259                    (textual? . ,lh-woodwind-text-stencil)
1260                    (offset . (1.5 . 3.75)))
1261                   ((stencils
1262                     . ,(make-right-hand-key-addresses
1263                           '(e c bes high-fis fis ees low-c)))
1264                    (textual? . ,rh-woodwind-text-stencil)
1265                    (offset . (-1.25 . 0.0)))))
1266               (xy-scale-function . (,identity . ,identity))
1267               (textual? . #f)
1268               (offset . (0.0 . 0.0))))
1269           (draw-instructions
1270            . ((,apply-group-draw-rule-series
1271                 (,(make-left-hand-key-addresses
1272                     '(ees d f front-f bes gis cis b low-bes))
1273                  ,(make-right-hand-key-addresses
1274                     '(e c bes high-fis fis ees low-c))))
1275               (,group-automate-rule
1276                  ,(make-central-column-hole-addresses
1277                     CENTRAL-COLUMN-HOLE-LIST))
1278               (,group-automate-rule ((hidden . midline)))))
1279           (extra-offset-instructions
1280            . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1281
1282 ;; Bassoon assembly instructions
1283
1284 (define bassoon-change-points
1285   ((make-named-spreadsheet '(bassoon contrabassoon))
1286     `((left-hand-additional-keys .
1287       (((a .
1288          ((offset . (0.0 . -0.3))
1289          (stencil . ,bassoon-lh-a-flick-key-stencil)
1290          (text? . ("A" . #f))
1291          (complexity . trill)))
1292         (w .
1293          ((offset . (0.0 . 0.0))
1294          (stencil . ,bassoon-lh-whisper-key-stencil)
1295          (text? . ("w" . #f))
1296          (complexity . trill))))
1297         ()))
1298       (right-hand-additional-keys .
1299       (((cis .
1300           ((offset . (0.0 . 0.0))
1301           (stencil . ,bassoon-rh-cis-key-stencil)
1302           (text? . ("C" . 1))
1303           (complexity . trill)))
1304         (thumb-gis .
1305           ((offset . (0.0 . 0.0))
1306           (stencil . ,bassoon-rh-thumb-gis-key-stencil)
1307           (text? . ("G" . 1))
1308           (complexity . trill))))
1309         ()))
1310      (left-hand-flick-group .
1311        (((left-hand . d) (left-hand . c) (left-hand . a))
1312          ((left-hand . d) (left-hand . c))))
1313      (left-hand-thumb-group .
1314        (((left-hand . w) (left-hand . thumb-cis))
1315          ((left-hand . thumb-cis))))
1316      (cis-offset-instruction .
1317        (((,rich-group-extra-offset-rule
1318          ((right-hand . cis))
1319          ,(append
1320            '((hidden . midline) (hidden . long-midline))
1321            (make-central-column-hole-addresses '(three two one))
1322            (make-left-hand-key-addresses
1323             '(low-b low-bes low-c low-d d a c w thumb-cis
1324               high-ees high-e cis ees)))
1325          (0.0 . 0.9)))
1326         ()))
1327      (right-hand-lower-thumb-group .
1328        (((right-hand . thumb-gis) (right-hand . thumb-fis))
1329          ((right-hand . thumb-fis))))
1330      (right-hand-cis-key .
1331        ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22)))
1332          ()))
1333      (back-left-hand-key-addresses .
1334       ((low-b low-bes low-c low-d d a c w thumb-cis)
1335        (low-b low-bes low-c low-d d c thumb-cis)))
1336      (front-right-hand-key-addresses .
1337       ((cis bes fis f gis) (bes fis f gis)))
1338      (back-right-hand-key-addresses .
1339       ((thumb-bes thumb-gis thumb-e thumb-fis)
1340        (thumb-bes thumb-e thumb-fis))))))
1341
1342 (define (generate-bassoon-family-entry bassoon-name)
1343   (let*
1344     ((change-points
1345      (get-named-spreadsheet-column bassoon-name bassoon-change-points)))
1346   `(,bassoon-name
1347     . ((keys
1348         . ((hidden
1349             . ((midline
1350                 .  ((offset . (0.0 . 0.0))
1351                     (stencil . ,midline-stencil)
1352                     (text? . #f)
1353                     (complexity . basic)))
1354                (long-midline
1355                 . ((offset . (0.0 . 0.0))
1356                    (stencil . ,long-midline-stencil)
1357                    (text? . #f)
1358                    (complexity . basic)))))
1359            (central-column
1360             . ((one
1361                 . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
1362                    (stencil . ,bassoon-cc-one-key-stencil)
1363                    (text? . #f)
1364                    (complexity . trill)))
1365                (two
1366                 . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
1367                    (stencil . ,ring-column-circle-stencil)
1368                    (text? . #f)
1369                    (complexity . ring)))
1370                (three
1371                 . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
1372                    (stencil . ,ring-column-circle-stencil)
1373                    (text? . #f)
1374                    (complexity . ring)))
1375                (four
1376                 . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
1377                    (stencil . ,ring-column-circle-stencil)
1378                    (text? . #f)
1379                    (complexity . ring)))
1380                (five
1381                 . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
1382                    (stencil . ,ring-column-circle-stencil)
1383                    (text? . #f)
1384                    (complexity . ring)))
1385                (six
1386                 . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
1387                    (stencil . ,ring-column-circle-stencil)
1388                    (text? . #f)
1389                    (complexity . ring)))))
1390            (left-hand
1391             . ,(append (assoc-get 'left-hand-additional-keys
1392                                   change-points)
1393                        `((high-e
1394                           . ((offset . (0.0 . 0.0))
1395                              (stencil . ,bassoon-lh-he-key-stencil)
1396                              (text? . ("hE" . #f))
1397                              (complexity . trill)))
1398                          (high-ees
1399                           . ((offset . (0.0 . 0.0))
1400                              (stencil . ,bassoon-lh-hees-key-stencil)
1401                              (text? . ("hE" . 0))
1402                              (complexity . trill)))
1403                          (ees
1404                           . ((offset . (-1.0 . 1.0))
1405                              (stencil . ,bassoon-lh-ees-key-stencil)
1406                              (text? . ("E" . 0))
1407                              (complexity . trill)))
1408                          (cis
1409                           . ((offset . (0.0 . 0.0))
1410                              (stencil . ,bassoon-lh-cis-key-stencil)
1411                              (text? . ("C" . 1))
1412                              (complexity . trill)))
1413                          (low-bes
1414                           . ((offset . (0.0 . 0.0))
1415                              (stencil . ,bassoon-lh-lbes-key-stencil)
1416                              (text? . ("b" . 0))
1417                              (complexity . trill)))
1418                          (low-b
1419                           . ((offset . (-1.0 . -0.7))
1420                              (stencil . ,bassoon-lh-lb-key-stencil)
1421                              (text? . ("b" . #f))
1422                              (complexity . trill)))
1423                          (low-c
1424                           . ((offset . (0.0 . 0.0))
1425                              (stencil . ,bassoon-lh-lc-key-stencil)
1426                              (text? . ("c" . #f))
1427                              (complexity . trill)))
1428                          (low-d
1429                           . ((offset . (0.0 . 0.0))
1430                              (stencil . ,bassoon-lh-ld-key-stencil)
1431                              (text? . ("d" . #f))
1432                              (complexity . trill)))
1433                          (d
1434                           . ((offset . (-1.5 . 2.0))
1435                              (stencil . ,bassoon-lh-d-flick-key-stencil)
1436                              (text? . ("D" . #f))
1437                              (complexity . trill)))
1438                          (c
1439                           . ((offset . (-0.8 . 1.1))
1440                              (stencil . ,bassoon-lh-c-flick-key-stencil)
1441                              (text? . ("C" . #f))
1442                              (complexity . trill)))
1443                          (thumb-cis
1444                           . ((offset . (2.0 . -1.0))
1445                              (stencil . ,bassoon-lh-thumb-cis-key-stencil)
1446                              (text? . ("C" . 1))
1447                              (complexity . trill))))))
1448            (right-hand
1449             . ,(append (assoc-get 'right-hand-additional-keys
1450                                   change-points)
1451                        `((bes
1452                           . ((offset . (0.0 . 0.8))
1453                              (stencil . ,bassoon-rh-bes-key-stencil)
1454                              (text? . ("B" . 0))
1455                              (complexity . trill)))
1456                          (f
1457                           . ((offset . (-2.2 . 4.35))
1458                              (stencil . ,bassoon-rh-f-key-stencil)
1459                              (text? . ("F" . #f))
1460                              (complexity . trill)))
1461                          (fis
1462                           . ((offset . (1.5 . 1.0))
1463                              (stencil . ,bassoon-rh-fis-key-stencil)
1464                              (text? . ("F" . 1))
1465                              (complexity . trill)))
1466                          (gis
1467                           . ((offset . (0.0 . -0.15))
1468                              (stencil . ,bassoon-rh-gis-key-stencil)
1469                              (text? . ("G" . 1))
1470                              (complexity . trill)))
1471                          (thumb-bes
1472                           . ((offset . (0.0 . 0.0))
1473                              (stencil . ,bassoon-rh-thumb-bes-key-stencil)
1474                              (text? . ("B" . 0))
1475                              (complexity . trill)))
1476                          (thumb-e
1477                           . ((offset . (1.75 . 0.4))
1478                              (stencil . ,bassoon-rh-thumb-e-key-stencil)
1479                              (text? . ("E" . #f))
1480                              (complexity . trill)))
1481                          (thumb-fis
1482                           . ((offset . (-1.0 . 1.6))
1483                              (stencil . ,bassoon-rh-thumb-fis-key-stencil)
1484                              (text? . ("F" . 1))
1485                              (complexity . trill))))))))
1486        (graphical-commands
1487         . ((stencil-alist
1488             . ((stencils
1489                 . ,(append (assoc-get 'right-hand-cis-key change-points)
1490                            `(,(simple-stencil-alist '(hidden . midline)
1491                                                     '(0.0 . 3.75))
1492                              ,(simple-stencil-alist '(hidden . long-midline)
1493                                                     '(0.0 . 3.80))
1494                              ((stencils
1495                                . ,(make-central-column-hole-addresses
1496                                      CENTRAL-COLUMN-HOLE-LIST))
1497                               (xy-scale-function . (,identity . ,identity))
1498                               (textual? . #f)
1499                               (offset . (0.0 . 0.0)))
1500                              ,(simple-stencil-alist '(left-hand . high-e)
1501                                                     '(-1.0 . 7.0))
1502                              ,(simple-stencil-alist '(left-hand . high-ees)
1503                                                     '(-1.0 . 6.0))
1504                              ((stencils
1505                                . ((left-hand . ees) (left-hand . cis)))
1506                               (xy-scale-function . (,return-1 . ,return-1))
1507                               (textual? . #f)
1508                               (offset . (3.0 . 3.75)))
1509                              ((stencils
1510                                . (((stencils
1511                                     . ((left-hand . low-b)
1512                                        (left-hand . low-bes)))
1513                                    (xy-scale-function
1514                                     . (,return-1 . ,return-1))
1515                                    (textual? . #f)
1516                                    (offset . (-2.0 . 9.0)))
1517                                   ((stencils
1518                                     . ,(assoc-get 'left-hand-flick-group
1519                                                   change-points))
1520                                    (xy-scale-function
1521                                     . (,return-1 . ,return-1))
1522                                    (textual? . #f)
1523                                    (offset . (3.0 . 7.0)))
1524                                   ,(simple-stencil-alist '(left-hand . low-c)
1525                                                          '(-1.0 . 4.5))
1526                                   ,(simple-stencil-alist '(left-hand . low-d)
1527                                                          '(-1.0 . 0.1))
1528                                   ((stencils
1529                                     . ,(assoc-get 'left-hand-thumb-group
1530                                                   change-points))
1531                                    (xy-scale-function
1532                                     . (,return-1 . ,return-1))
1533                                    (textual? . #f)
1534                                    (offset . (1.5 . -0.6)))))
1535                               (xy-scale-function . (,return-1 . ,return-1))
1536                               (textual? . #f)
1537                               (offset . (-5.5 . 4.7)))
1538                              ,(simple-stencil-alist '(right-hand . bes)
1539                                                     '(1.0 . 1.2))
1540                              ((stencils
1541                                . ,(make-right-hand-key-addresses '(gis f fis)))
1542                               (xy-scale-function . (,return-1 . ,return-1))
1543                               (textual? . #f)
1544                               (offset . (2.0 . -1.25)))
1545                              ((stencils
1546                                . (((stencils
1547                                     . ((right-hand . thumb-bes)
1548                                        (right-hand . thumb-e)))
1549                                    (xy-scale-function
1550                                     . (,return-1 . ,return-1))
1551                                    (textual? . #f)
1552                                    (offset . (-1.22 . 5.25)))
1553                                   ((stencils
1554                                     . ,(assoc-get 'right-hand-lower-thumb-group
1555                                                   change-points))
1556                                    (xy-scale-function
1557                                     . (,return-1 . ,return-1))
1558                                    (textual? . #f)
1559                                    (offset . (0.0 . 0.0)))))
1560                               (xy-scale-function
1561                                . (,return-1 . ,return-1))
1562                               (textual? . #f)
1563                               (offset . (-5.0 . 0.0))))))
1564                (xy-scale-function . (,identity . ,identity))
1565                (textual? . #f)
1566                (offset . (0.0 . 0.0))))
1567            (draw-instructions
1568             . ((,apply-group-draw-rule-series
1569                 (,(make-left-hand-key-addresses '(ees cis))
1570                  ,(make-left-hand-key-addresses
1571                  (assoc-get 'back-left-hand-key-addresses change-points))
1572                  ,(make-right-hand-key-addresses '(f fis gis))
1573                  ,(make-right-hand-key-addresses
1574                  (assoc-get 'back-right-hand-key-addresses change-points))))
1575                (,group-automate-rule
1576                 ,(make-central-column-hole-addresses
1577                   CENTRAL-COLUMN-HOLE-LIST))
1578                (,bassoon-midline-rule
1579                   ,(append
1580                      (make-left-hand-key-addresses
1581                        (assoc-get 'back-left-hand-key-addresses change-points))
1582                      (make-right-hand-key-addresses
1583                         (assoc-get 'back-right-hand-key-addresses
1584                                    change-points))))))
1585            (extra-offset-instructions
1586             . ,(append
1587                  (assoc-get 'cis-offset-instruction change-points)
1588                  `((,uniform-extra-offset-rule (0.0 . 0.0)))))))
1589        (text-commands
1590         . ((stencil-alist
1591             . ((stencils
1592                 . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
1593                    ((stencils
1594                      . ,(make-central-column-hole-addresses
1595                          CENTRAL-COLUMN-HOLE-LIST))
1596                     (xy-scale-function . (,identity . ,identity))
1597                     (textual? . #f)
1598                     (offset . (0.0 . 0.0)))
1599                    ((stencils
1600                      . ,(make-left-hand-key-addresses
1601                            '(high-e high-ees ees cis)))
1602                     (textual? . ,lh-woodwind-text-stencil)
1603                     (offset . (1.5 . 3.75)))
1604                    ((stencils
1605                      . ,(make-left-hand-key-addresses
1606                           (assoc-get 'back-left-hand-key-addresses
1607                                      change-points)))
1608                     (textual? . ,rh-woodwind-text-stencil)
1609                     (offset . (-1.25 . 3.75)))
1610                    ((stencils
1611                      . ,(make-right-hand-key-addresses
1612                           (assoc-get 'front-right-hand-key-addresses
1613                                      change-points)))
1614                     (textual? . ,lh-woodwind-text-stencil)
1615                     (offset . (1.5 . 0.0)))
1616                    ((stencils .
1617                      ,(make-right-hand-key-addresses
1618                        (assoc-get 'back-right-hand-key-addresses
1619                                   change-points)))
1620                     (textual? . ,rh-woodwind-text-stencil)
1621                     (offset . (-1.25 . 0.0)))))
1622                (xy-scale-function . (,identity . ,identity))
1623                (textual? . #f)
1624                (offset . (0.0 . 0.0))))
1625            (draw-instructions
1626             . ((,apply-group-draw-rule-series
1627                  (,(make-left-hand-key-addresses
1628                      (assoc-get 'back-left-hand-key-addresses change-points))
1629                   ,(make-right-hand-key-addresses
1630                      (assoc-get 'front-right-hand-key-addresses change-points))
1631                   ,(make-right-hand-key-addresses
1632                       (assoc-get 'back-right-hand-key-addresses change-points))
1633                   ,(make-left-hand-key-addresses '(high-e high-ees ees cis))))
1634                (,group-automate-rule
1635                  ,(make-central-column-hole-addresses
1636                      CENTRAL-COLUMN-HOLE-LIST))
1637                (,group-automate-rule ((hidden . midline)))))
1638            (extra-offset-instructions
1639             . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
1640
1641 ;; Assembly functions
1642
1643 ; Scans a bank for name.
1644 ; for example, '(left-hand . bes) will return bes in the left-hand
1645 ; of a given bank
1646 (define (get-key name bank)
1647   (assoc-get (cdr name) (assoc-get (car name) bank)))
1648
1649 (define (translate-key-instruction key-instruction)
1650   (let*
1651     ((key-name (car key-instruction))
1652     (key-complexity (assoc-get 'complexity (cdr key-instruction))))
1653    (cond
1654     ((eqv? key-complexity 'basic)
1655       `((,key-name . ,(assoc-get 'F HOLE-FILL-LIST))))
1656     ((eqv? key-complexity 'trill)
1657        (make-symbol-alist key-name #t #f))
1658     ((eqv? key-complexity 'covered)
1659        (make-symbol-alist key-name #f #f))
1660     ((eqv? key-complexity 'ring)
1661        (make-symbol-alist key-name #f #t)))))
1662
1663 (define (update-possb-list input-key possibility-list canonic-list)
1664   (if (null? possibility-list)
1665     (ly:error "woodwind markup error - invalid key or hole requested")
1666     (if
1667       (assoc-get input-key (cdar possibility-list))
1668       (append
1669         `(((,(caaar possibility-list) .
1670             ,(assoc-get input-key (cdar possibility-list))) .
1671            ,(assoc-get (caar possibility-list) canonic-list)))
1672           (assoc-remove (caar possibility-list) canonic-list))
1673       (update-possb-list input-key (cdr possibility-list) canonic-list))))
1674
1675 (define (key-crawler input-list possibility-list)
1676   (if (null? input-list)
1677     (map car possibility-list)
1678     (key-crawler
1679       (cdr input-list)
1680       (update-possb-list
1681         (car input-list)
1682         possibility-list
1683         possibility-list))))
1684
1685 (define (translate-draw-instructions input-alist key-name-alist)
1686   (apply append
1687     (map (lambda (short long)
1688            (let*
1689              ((key-instructions
1690                (map (lambda (instr)
1691                       `(((,long . ,(car instr)) . 0)
1692                         . ,(translate-key-instruction instr)))
1693                     (assoc-get long key-name-alist))))
1694             (key-crawler (assoc-get short input-alist) key-instructions)))
1695          '(hd cc lh rh)
1696          '(hidden central-column left-hand right-hand))))
1697
1698 (define (uniform-draw-instructions key-name-alist)
1699     (apply append
1700       (map (lambda (long)
1701              (map (lambda (key-instructions)
1702                     `((,long . ,(car key-instructions)) . 1))
1703                   (assoc-get long key-name-alist)))
1704            '(hidden central-column left-hand right-hand))))
1705
1706 (define (list-all-possible-keys key-name-alist)
1707   (map (lambda (short long)
1708          `(,short
1709            . ,(map (lambda (key-instructions)
1710                      (car key-instructions))
1711                    (assoc-get long key-name-alist))))
1712        '(cc lh rh)
1713        '(central-column left-hand right-hand)))
1714
1715 (define (list-all-possible-keys-verbose key-name-alist)
1716   (map (lambda (short long)
1717          `(,short
1718            . ,(map (lambda (key-instructions)
1719                      `(,(car key-instructions)
1720                        . ,(map (lambda (x)
1721                                  (car x))
1722                                (translate-key-instruction key-instructions))))
1723                    (assoc-get long key-name-alist))))
1724        '(cc lh rh)
1725        '(central-column left-hand right-hand)))
1726
1727 (define woodwind-data-assembly-instructions
1728   `((,generate-flute-family-entry . piccolo)
1729     (,generate-flute-family-entry . flute)
1730     (,generate-flute-family-entry . flute-b-extension)
1731     (,generate-tin-whistle-family-entry . tin-whistle)
1732     (,generate-oboe-family-entry . oboe)
1733     (,generate-clarinet-family-entry . clarinet)
1734     (,generate-clarinet-family-entry . bass-clarinet)
1735     (,generate-clarinet-family-entry . low-bass-clarinet)
1736     (,generate-saxophone-family-entry . saxophone)
1737     (,generate-saxophone-family-entry . soprano-saxophone)
1738     (,generate-saxophone-family-entry . alto-saxophone)
1739     (,generate-saxophone-family-entry . tenor-saxophone)
1740     (,generate-saxophone-family-entry . baritone-saxophone)
1741     (,generate-bassoon-family-entry . bassoon)
1742     (,generate-bassoon-family-entry . contrabassoon)))
1743
1744 (define-public woodwind-instrument-list
1745   (map cdr woodwind-data-assembly-instructions))
1746
1747 (define woodwind-data-alist
1748   (map (lambda (instruction)
1749          ((car instruction) (cdr instruction)))
1750        woodwind-data-assembly-instructions))
1751
1752 ;;; The brains of the markup function: takes drawing and offset information
1753 ;;; about a key region and calls the appropriate stencils to draw the region.
1754
1755 (define
1756   (assemble-stencils
1757     stencil-alist
1758     key-bank
1759     draw-instructions
1760     extra-offset-instructions
1761     radius
1762     thick
1763     xy-stretch
1764     layout
1765     props)
1766   (apply
1767     ly:stencil-add
1768     (map (lambda (node)
1769            (ly:stencil-translate
1770              (if (pair? (cdr node))
1771                  (if (assoc-get 'textual? node)
1772                      ((assoc-get 'textual? node) (map (lambda (key)
1773                                                         (assoc-get 'text? key))
1774                                                       (map (lambda (instr)
1775                                                              (get-key
1776                                                                instr
1777                                                                key-bank))
1778                                                  (assoc-get 'stencils node)))
1779                                                  radius
1780                                                  (map (lambda (key)
1781                                                         (assoc-get
1782                                                           key
1783                                                           draw-instructions))
1784                                                       (assoc-get 'stencils
1785                                                                  node))
1786                                                  layout
1787                                                  props)
1788                      (assemble-stencils
1789                        node
1790                        key-bank
1791                        draw-instructions
1792                        extra-offset-instructions
1793                        radius
1794                        thick
1795                        (coord-apply (assoc-get 'xy-scale-function stencil-alist)
1796                                     xy-stretch)
1797                        layout
1798                        props))
1799                (if (= 0 (assoc-get node draw-instructions))
1800                    empty-stencil
1801                    ((assoc-get 'stencil (get-key node key-bank))
1802                      radius
1803                      thick
1804                      (assoc-get node draw-instructions)
1805                      layout
1806                      props)))
1807              (coord-scale
1808                (coord-translate
1809                  (coord-scale
1810                    (assoc-get
1811                      'offset
1812                      (if (pair? (cdr node))
1813                        node
1814                        (get-key node key-bank)))
1815                    (coord-apply
1816                      (assoc-get 'xy-scale-function stencil-alist)
1817                      xy-stretch))
1818                  (if
1819                    (assoc-get node extra-offset-instructions)
1820                    (assoc-get node extra-offset-instructions)
1821                    '(0.0 . 0.0)))
1822                radius)))
1823          (assoc-get 'stencils stencil-alist))))
1824
1825 (define-public (print-keys instrument)
1826   (let*
1827     ((chosen-instrument
1828       (begin
1829         (format #t "\nPrinting keys for: ~a\n" instrument)
1830         (assoc-get instrument woodwind-data-alist)))
1831    (key-list (list-all-possible-keys (assoc-get 'keys chosen-instrument))))
1832   (define (key-list-loop key-list)
1833     (if (null? key-list)
1834       0
1835       (begin
1836         (format #t "~a\n   ~a\n" (caar key-list) (cdar key-list))
1837         (key-list-loop (cdr key-list)))))
1838   (key-list-loop key-list)))
1839
1840 (define-public (get-woodwind-key-list instrument)
1841   (list-all-possible-keys-verbose
1842     (assoc-get
1843       'keys
1844       (assoc-get instrument woodwind-data-alist))))
1845
1846 (define-public (print-keys-verbose instrument)
1847   (let*
1848     ((chosen-instrument
1849       (begin
1850         (format #t "\nPrinting keys in verbose mode for: ~a\n" instrument)
1851         (assoc-get instrument woodwind-data-alist)))
1852    (key-list
1853      (list-all-possible-keys-verbose (assoc-get 'keys chosen-instrument))))
1854   (define (key-list-loop key-list)
1855     (if (null? key-list)
1856       0
1857       (begin
1858         (format #t "~a\n" (caar key-list))
1859         (map (lambda (x)
1860                (format #t "   possibilities for ~a:\n      ~a\n" (car x) (cdr x)))
1861              (cdar key-list))
1862         (key-list-loop (cdr key-list)))))
1863   (key-list-loop key-list)))
1864
1865 (define-markup-command
1866   (woodwind-diagram layout props instrument user-draw-commands)
1867   (symbol? list?)
1868   #:category instrument-specific-markup ; markup category
1869   #:properties ((size 1)
1870                 (thickness 0.1)
1871                 (graphical #t))
1872   "Make a woodwind-instrument diagram.  For example, say
1873
1874 @example
1875 \\markup \\woodwind-diagram
1876   #'oboe #'((lh . (d ees)) (cc . (five3qT1q)) (rh . (gis)))
1877 @end example
1878
1879 @noindent
1880 for an oboe with the left-hand d key, left-hand ees key,
1881 and right-hand gis key depressed while the five-hole of
1882 the central column effectuates a trill between 1/4 and 3/4 closed.
1883
1884 The following instruments are supported:
1885 @itemize @minus
1886
1887 @item
1888 piccolo
1889
1890 @item
1891 flute
1892
1893 @item
1894 oboe
1895
1896 @item
1897 clarinet
1898
1899 @item
1900 bass-clarinet
1901
1902 @item
1903 saxophone
1904
1905 @item
1906 bassoon
1907
1908 @item
1909 contrabassoon
1910
1911 @end itemize
1912
1913 To see all of the callable keys for a given instrument,
1914 include the function @code{(print-keys 'instrument)}
1915 in your .ly file, where instrument is the instrument
1916 whose keys you want to print.
1917
1918 Certain keys allow for special configurations.  The entire gamut of
1919 configurations possible is as follows:
1920
1921 @itemize @minus
1922
1923 @item
1924 1q (1/4 covered)
1925
1926 @item
1927 1h (1/2 covered)
1928
1929 @item
1930 3q (3/4 covered)
1931
1932 @item
1933 R (ring depressed)
1934
1935 @item
1936 F (fully covered; the default if no state put)
1937
1938 @end itemize
1939
1940 Additionally, these configurations can be used in trills.  So, for example,
1941 @code{three3qTR} effectuates a trill between 3/4 full and ring depressed
1942 on the three hole.  As another example, @code{threeRT} effectuates a trill
1943 between R and open, whereas @code{threeTR} effectuates a trill between open
1944 and shut.  To see all of the possibilities for all of the keys of a given
1945 instrument, invoke @code{(print-keys-verbose 'instrument)}.
1946
1947 Lastly, substituting an empty list for the pressed-key alist will result in
1948 a diagram with all of the keys drawn but none filled, for example:
1949
1950 @example
1951 \\markup \\woodwind-diagram #'oboe #'()
1952 @end example"
1953   (let*  ((radius size)
1954           (thick (* size thickness))
1955           (display-graphic graphical)
1956           (xy-stretch `(1.0 . 2.5))
1957           (chosen-instrument (assoc-get instrument woodwind-data-alist))
1958           (chosen-instrument
1959             (if (not chosen-instrument)
1960                 (ly:error "~a is not a valid woodwind instrument."
1961                           instrument)
1962                 chosen-instrument))
1963           (stencil-info
1964             (assoc-get
1965               (if display-graphic 'graphical-commands 'text-commands)
1966               chosen-instrument))
1967           (pressed-info
1968             (if (null? user-draw-commands)
1969                 (uniform-draw-instructions (assoc-get 'keys chosen-instrument))
1970                 (translate-draw-instructions
1971                   (append '((hd . ())) user-draw-commands)
1972                   (assoc-get 'keys chosen-instrument))))
1973           (draw-info
1974             (function-chain
1975               pressed-info
1976               (assoc-get 'draw-instructions stencil-info)))
1977           (extra-offset-info
1978             (function-chain
1979               pressed-info
1980               (assoc-get 'extra-offset-instructions stencil-info))))
1981     (assemble-stencils
1982       (assoc-get 'stencil-alist stencil-info)
1983       (assoc-get 'keys chosen-instrument)
1984       draw-info
1985       extra-offset-info
1986       radius
1987       thick
1988       xy-stretch
1989       layout
1990       props)))