scm/display-woodwind-diagrams.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2010--2012 Mike Solomon <mikesol@stanfordalumni.org>
   4 ;;;;
   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           (assoc-remove (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   (apply append
1689     (map (lambda (short long)
1690            (let*
1691              ((key-instructions
1692                (map (lambda (instr)
1693                       `(((,long . ,(car instr)) . 0)
1694                         . ,(translate-key-instruction instr)))
1695                     (assoc-get long key-name-alist))))
1696             (key-crawler (assoc-get short input-alist) key-instructions)))
1697          '(hd cc lh rh)
1698          '(hidden central-column left-hand right-hand))))
1699
1700 (define (uniform-draw-instructions key-name-alist)
1701     (apply append
1702       (map (lambda (long)
1703              (map (lambda (key-instructions)
1704                     `((,long . ,(car key-instructions)) . 1))
1705                   (assoc-get long key-name-alist)))
1706            '(hidden central-column left-hand right-hand))))
1707
1708 (define (list-all-possible-keys key-name-alist)
1709   (map (lambda (short long)
1710          `(,short
1711            . ,(map (lambda (key-instructions)
1712                      (car key-instructions))
1713                    (assoc-get long key-name-alist))))
1714        '(cc lh rh)
1715        '(central-column left-hand right-hand)))
1716
1717 (define (list-all-possible-keys-verbose key-name-alist)
1718   (map (lambda (short long)
1719          `(,short
1720            . ,(map (lambda (key-instructions)
1721                      `(,(car key-instructions)
1722                        . ,(map (lambda (x)
1723                                  (car x))
1724                                (translate-key-instruction key-instructions))))
1725                    (assoc-get long key-name-alist))))
1726        '(cc lh rh)
1727        '(central-column left-hand right-hand)))
1728
1729 (define woodwind-data-assembly-instructions
1730   `((,generate-flute-family-entry . piccolo)
1731     (,generate-flute-family-entry . flute)
1732     (,generate-flute-family-entry . flute-b-extension)
1733     (,generate-tin-whistle-family-entry . tin-whistle)
1734     (,generate-oboe-family-entry . oboe)
1735     (,generate-clarinet-family-entry . clarinet)
1736     (,generate-clarinet-family-entry . bass-clarinet)
1737     (,generate-clarinet-family-entry . low-bass-clarinet)
1738     (,generate-saxophone-family-entry . saxophone)
1739     (,generate-saxophone-family-entry . soprano-saxophone)
1740     (,generate-saxophone-family-entry . alto-saxophone)
1741     (,generate-saxophone-family-entry . tenor-saxophone)
1742     (,generate-saxophone-family-entry . baritone-saxophone)
1743     (,generate-bassoon-family-entry . bassoon)
1744     (,generate-bassoon-family-entry . contrabassoon)))
1745
1746 (define-public woodwind-instrument-list
1747   (map cdr woodwind-data-assembly-instructions))
1748
1749 (define woodwind-data-alist
1750   (map (lambda (instruction)
1751          ((car instruction) (cdr instruction)))
1752        woodwind-data-assembly-instructions))
1753
1754 ;;; The brains of the markup function: takes drawing and offset information
1755 ;;; about a key region and calls the appropriate stencils to draw the region.
1756
1757 (define
1758   (assemble-stencils
1759     stencil-alist
1760     key-bank
1761     draw-instructions
1762     extra-offset-instructions
1763     radius
1764     thick
1765     xy-stretch
1766     layout
1767     props)
1768   (apply
1769     ly:stencil-add
1770     (map (lambda (node)
1771            (ly:stencil-translate
1772              (if (pair? (cdr node))
1773                  (if (assoc-get 'textual? node)
1774                      ((assoc-get 'textual? node) (map (lambda (key)
1775                                                         (assoc-get 'text? key))
1776                                                       (map (lambda (instr)
1777                                                              (get-key
1778                                                                instr
1779                                                                key-bank))
1780                                                  (assoc-get 'stencils node)))
1781                                                  radius
1782                                                  (map (lambda (key)
1783                                                         (assoc-get
1784                                                           key
1785                                                           draw-instructions))
1786                                                       (assoc-get 'stencils
1787                                                                  node))
1788                                                  layout
1789                                                  props)
1790                      (assemble-stencils
1791                        node
1792                        key-bank
1793                        draw-instructions
1794                        extra-offset-instructions
1795                        radius
1796                        thick
1797                        (coord-apply (assoc-get 'xy-scale-function stencil-alist)
1798                                     xy-stretch)
1799                        layout
1800                        props))
1801                (if (= 0 (assoc-get node draw-instructions))
1802                    empty-stencil
1803                    ((assoc-get 'stencil (get-key node key-bank))
1804                      radius
1805                      thick
1806                      (assoc-get node draw-instructions)
1807                      layout
1808                      props)))
1809              (coord-scale
1810                (coord-translate
1811                  (coord-scale
1812                    (assoc-get
1813                      'offset
1814                      (if (pair? (cdr node))
1815                        node
1816                        (get-key node key-bank)))
1817                    (coord-apply
1818                      (assoc-get 'xy-scale-function stencil-alist)
1819                      xy-stretch))
1820                  (if
1821                    (assoc-get node extra-offset-instructions)
1822                    (assoc-get node extra-offset-instructions)
1823                    '(0.0 . 0.0)))
1824                radius)))
1825          (assoc-get 'stencils stencil-alist))))
1826
1827 (define*-public (print-keys instrument #:optional (port (current-output-port)))
1828   (format port "\nPrinting keys for: ~a\n" instrument)
1829   (let ((chosen-instrument (assoc-get instrument woodwind-data-alist)))
1830     (do ((key-list
1831           (list-all-possible-keys (assoc-get 'keys chosen-instrument))
1832           (cdr key-list)))
1833         ((null? key-list))
1834       (format port "~a\n   ~a\n" (caar key-list) (cdar key-list)))))
1835
1836 (define-public (get-woodwind-key-list instrument)
1837   (list-all-possible-keys-verbose
1838     (assoc-get
1839       'keys
1840       (assoc-get instrument woodwind-data-alist))))
1841
1842 (define*-public (print-keys-verbose instrument
1843                                     #:optional (port (current-output-port)))
1844   (format port "\nPrinting keys in verbose mode for: ~a\n" instrument)
1845   (do ((key-list (get-woodwind-key-list instrument)
1846                  (cdr key-list)))
1847       ((null? key-list))
1848     (format port "~a\n" (caar key-list))
1849     (for-each
1850      (lambda (x)
1851        (format port "   possibilities for ~a:\n      ~a\n" (car x) (cdr x)))
1852      (cdar key-list))))
1853
1854 (define-markup-command
1855   (woodwind-diagram layout props instrument user-draw-commands)
1856   (symbol? list?)
1857   #:category instrument-specific-markup ; markup category
1858   #:properties ((size 1)
1859                 (thickness 0.1)
1860                 (graphical #t))
1861   "Make a woodwind-instrument diagram.  For example, say
1862
1863 @example
1864 \\markup \\woodwind-diagram
1865   #'oboe #'((lh . (d ees)) (cc . (five3qT1q)) (rh . (gis)))
1866 @end example
1867
1868 @noindent
1869 for an oboe with the left-hand d key, left-hand ees key,
1870 and right-hand gis key depressed while the five-hole of
1871 the central column effectuates a trill between 1/4 and 3/4 closed.
1872
1873 The following instruments are supported:
1874 @itemize @minus
1875
1876 @item
1877 piccolo
1878
1879 @item
1880 flute
1881
1882 @item
1883 oboe
1884
1885 @item
1886 clarinet
1887
1888 @item
1889 bass-clarinet
1890
1891 @item
1892 saxophone
1893
1894 @item
1895 bassoon
1896
1897 @item
1898 contrabassoon
1899
1900 @end itemize
1901
1902 To see all of the callable keys for a given instrument,
1903 include the function @code{(print-keys 'instrument)}
1904 in your .ly file, where instrument is the instrument
1905 whose keys you want to print.
1906
1907 Certain keys allow for special configurations.  The entire gamut of
1908 configurations possible is as follows:
1909
1910 @itemize @minus
1911
1912 @item
1913 1q (1/4 covered)
1914
1915 @item
1916 1h (1/2 covered)
1917
1918 @item
1919 3q (3/4 covered)
1920
1921 @item
1922 R (ring depressed)
1923
1924 @item
1925 F (fully covered; the default if no state put)
1926
1927 @end itemize
1928
1929 Additionally, these configurations can be used in trills.  So, for example,
1930 @code{three3qTR} effectuates a trill between 3/4 full and ring depressed
1931 on the three hole.  As another example, @code{threeRT} effectuates a trill
1932 between R and open, whereas @code{threeTR} effectuates a trill between open
1933 and shut.  To see all of the possibilities for all of the keys of a given
1934 instrument, invoke @code{(print-keys-verbose 'instrument)}.
1935
1936 Lastly, substituting an empty list for the pressed-key alist will result in
1937 a diagram with all of the keys drawn but none filled, for example:
1938
1939 @example
1940 \\markup \\woodwind-diagram #'oboe #'()
1941 @end example"
1942   (let*  ((radius size)
1943           (thick (* size thickness))
1944           (display-graphic graphical)
1945           (xy-stretch `(1.0 . 2.5))
1946           (chosen-instrument (assoc-get instrument woodwind-data-alist))
1947           (chosen-instrument
1948             (if (not chosen-instrument)
1949                 (ly:error "~a is not a valid woodwind instrument."
1950                           instrument)
1951                 chosen-instrument))
1952           (stencil-info
1953             (assoc-get
1954               (if display-graphic 'graphical-commands 'text-commands)
1955               chosen-instrument))
1956           (pressed-info
1957             (if (null? user-draw-commands)
1958                 (uniform-draw-instructions (assoc-get 'keys chosen-instrument))
1959                 (translate-draw-instructions
1960                   (append '((hd . ())) user-draw-commands)
1961                   (assoc-get 'keys chosen-instrument))))
1962           (draw-info
1963             (function-chain
1964               pressed-info
1965               (assoc-get 'draw-instructions stencil-info)))
1966           (extra-offset-info
1967             (function-chain
1968               pressed-info
1969               (assoc-get 'extra-offset-instructions stencil-info))))
1970     (assemble-stencils
1971       (assoc-get 'stencil-alist stencil-info)
1972       (assoc-get 'keys chosen-instrument)
1973       draw-info
1974       extra-offset-info
1975       radius
1976       thick
1977       xy-stretch
1978       layout
1979       props)))