scm/display-woodwind-diagrams.scm

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