--- /dev/null
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2010 Mike Solomon <mikesol@stanfordalumni.org>
+;;;; Clarinet drawings copied from diagrams created by
+;;;; Gilles Thibault <gilles.thibault@free.fr>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
+
+(define HOLE-FILL-LIST '((R . 3) (1q . 5) (1h . 7) (3q . 11) (F . 13)))
+
+;; Utility functions
+
+(define-public (symbol-concatenate . names)
+ "Like string-concatenate, but for symbols"
+ (string->symbol (apply string-append (map symbol->string names))))
+
+(define-public (function-chain arg function-list)
+ "Applies a list of functions in function list to arg.
+ Each element of function list is structured (cons function '(arg2 arg3 ...))
+ If function takes arguments besides arg, they are provided in function list.
+ For example:
+ @code{guile> (function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
+ @code{1/3}"
+ (if (null? function-list)
+ arg
+ (function-chain
+ (apply (caar function-list) (append `(,arg) (cdar function-list)))
+ (cdr function-list))))
+
+(define (rotunda-map function inlist rotunda)
+ "Like map, but with a rotating last argument to function.
+ For example:
+ @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))}
+ @code{(2 -8 4 -6)}"
+ (define (rotunda-map-chain function inlist outlist rotunda)
+ (if (null? inlist)
+ outlist
+ (rotunda-map-chain
+ function
+ (cdr inlist)
+ (append outlist (list (function (car inlist) (car rotunda))))
+ (append (cdr rotunda) (list (car rotunda))))))
+ (rotunda-map-chain function inlist '() rotunda))
+
+(define (assoc-keys alist)
+ "Gets the keys of an alist."
+ (map (lambda (x) (car x)) alist))
+
+(define (assoc-values alist)
+ "Gets the values of an alist."
+ (map (lambda (x) (cdr x)) alist))
+
+(define (get-slope-offset p1 p2)
+ "Gets the slope and offset for p1 and p2.
+ For example:
+ @code{(get-slope-offset '(1 . 2) '(3 . -5.1))}
+ @code{(-3.55 . 5.55)}"
+ (let*
+ ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2))))
+ (offset (- (cdr p1) (* slope (car p1)))))
+ `(,slope . ,offset)))
+
+(define (is-square? x input-list)
+ "Returns true if x is the square of a value in input-list."
+ (pair? (memv (inexact->exact (sqrt x)) input-list)))
+
+(define (satisfies-function? function input-list)
+ "Returns true if an element in @code{input-list} is true
+ when @code{function} is applied to it.
+ For example:
+ @code{guile> (satisfies-function? null? '((1 2) ()))}
+ @code{#t}
+ @code{guile> (satisfies-function? null? '((1 2) (3)))}
+ @code{#f}"
+ (if (null? input-list)
+ #f
+ (or (function (car input-list))
+ (satisfies-function? function (cdr input-list)))))
+
+(define (true-entry? input-list)
+ "Is there a true entry in @code{input-list}?"
+ (satisfies-function? identity input-list))
+
+(define (entry-greater-than-x? input-list x)
+ "Is there an entry greater than @code{x} in @code{input-list}?"
+ (satisfies-function? (lambda (y) (> y x)) input-list))
+
+(define (n-true-entries input-list)
+ "Returns number of true entries in @code{input-list}."
+ (reduce + 0 (map (lambda (x) (if x 1 0)) input-list)))
+
+(define (bezier-head-for-stencil bezier cut-point)
+ "Prepares a split-bezier to be used in a connected shape stencil."
+ (list-tail (flatten-list (car (split-bezier bezier cut-point))) 2))
+
+;; Translators for keys
+
+; Translates a "normal" key (open, closed, trill)
+(define (key-fill-translate fill)
+ (cond
+ ((= fill 1) #f)
+ ((= fill 2) #f)
+ ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
+ ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t)))
+
+; Similar to above, but trans vs opaque doesn't matter
+(define (text-fill-translate fill)
+ (cond
+ ((< fill 3) 1.0)
+ ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5)
+ ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0)))
+
+; Emits a list for the central-column-hole maker
+; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?)
+; Multiple values, such as (#t #f #f #t #f), mean a trill between
+; not-full and 3-quarters-full
+(define (process-fill-value fill)
+ (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1)))
+ (append `(,(or (< fill 3) (is-square? fill avals)))
+ (map (lambda (x) (= 0 (remainder fill x))) avals))))
+
+; Color a stencil gray
+(define (gray-colorize stencil)
+ (apply ly:stencil-in-color (cons stencil (x11-color 'grey))))
+
+; A connected shape stencil that is surrounded by proc
+(define (rich-mcs-stencil ls x-stretch y-stretch proc)
+ (lambda (radius thick fill layout props)
+ (let*
+ ((fill-translate (key-fill-translate fill))
+ (gray? (eqv? fill-translate 0.5)))
+ (ly:stencil-add
+ ((if gray? gray-colorize identity)
+ (proc
+ (make-connected-shape-stencil
+ ls
+ thick
+ (* x-stretch radius)
+ (* y-stretch radius)
+ #f
+ (if gray? #t fill-translate))))
+ (if (not gray?)
+ empty-stencil
+ ((rich-mcs-stencil ls x-stretch y-stretch proc)
+ radius
+ thick
+ 1
+ layout
+ props))))))
+
+; A connected shape stencil without a surrounding proc
+(define (standard-mcs-stencil ls x-stretch y-stretch)
+ (rich-mcs-stencil ls x-stretch y-stretch identity))
+
+; An ellipse stencil that is surrounded by a proc
+(define (rich-pe-stencil x-stretch y-stretch start end proc)
+ (lambda (radius thick fill layout props)
+ (let*
+ ((fill-translate (key-fill-translate fill))
+ (gray? (eqv? fill-translate 0.5)))
+ (ly:stencil-add
+ ((if gray? gray-colorize identity)
+ (proc
+ (make-partial-ellipse-stencil
+ (* x-stretch radius)
+ (* y-stretch radius)
+ start
+ end
+ thick
+ #t
+ (if gray? #t fill-translate))))
+ (if (not gray?)
+ empty-stencil
+ ((rich-pe-stencil x-stretch y-stretch start end proc)
+ radius
+ thick
+ 1
+ layout
+ props))))))
+
+(define (rich-e-stencil x-stretch y-stretch proc)
+ (lambda (radius thick fill layout props)
+ (let*
+ ((fill-translate (key-fill-translate fill))
+ (gray? (eqv? fill-translate 0.5)))
+ (ly:stencil-add
+ ((if gray? gray-colorize identity)
+ (proc
+ (make-ellipse-stencil
+ (* x-stretch radius)
+ (* y-stretch radius)
+ thick
+ (if gray? #t fill-translate))))
+ (if (not gray?)
+ empty-stencil
+ ((rich-e-stencil x-stretch y-stretch proc)
+ radius
+ thick
+ 1
+ layout
+ props))))))
+
+; An ellipse stencil without a surrounding proc
+(define (standard-e-stencil x-stretch y-stretch)
+ (rich-e-stencil x-stretch y-stretch identity))
+
+; Translates all possible representations of symbol.
+; If simple? then the only representations are open, closed, and trill.
+; Otherwise, there can be various levels of "closure" on the holes
+; ring? allows for a ring around the holes as well
+(define (make-symbol-alist symbol simple? ring?)
+ (filter (lambda (x)
+ (not
+ (equal?
+ x
+ `(,(symbol-concatenate symbol 'T 'F) .
+ ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))))
+ (append
+ `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
+ (,(symbol-concatenate symbol 'T) .
+ ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))
+ (if simple?
+ '()
+ (apply append
+ (map (lambda (x)
+ (append
+ `((,(symbol-concatenate symbol (car x) 'T)
+ . ,(expt (cdr x) 2))
+ (,(symbol-concatenate symbol 'T (car x))
+ . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
+ (,(symbol-concatenate symbol (car x))
+ . ,(cdr x)))
+ (apply append
+ (map (lambda (y)
+ (map (lambda (a b)
+ `(,(symbol-concatenate symbol
+ (car a)
+ 'T
+ (car b))
+ . ,(* (cdr a) (cdr b))))
+ `(,x ,y) `(,y ,x)))
+ (cdr (member x HOLE-FILL-LIST))))))
+ (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST))))))))
+
+;;; Commands for text layout
+
+; Draws a circle around markup if (= trigger 0.5)
+(define-markup-command
+ (conditional-circle-markup layout props trigger in-markup)
+ (number? markup?)
+ (interpret-markup layout props
+ (if (eqv? trigger 0.5)
+ (markup #:circle (markup in-markup))
+ (markup in-markup))))
+
+; Makes a list of named-keys
+(define (make-name-keylist input-list key-list font-size)
+ (map (lambda (x y)
+ (if (< x 1)
+ (markup #:conditional-circle-markup
+ x
+ (make-concat-markup
+ (list
+ (markup #:abs-fontsize font-size (car y))
+ (if (and (< x 1) (cdr y))
+ (if (eqv? (cdr y) 1)
+ (markup
+ #:abs-fontsize
+ font-size
+ #:raise
+ 1
+ #:fontsize
+ -2
+ #:sharp)
+ (markup
+ #:abs-fontsize
+ font-size
+ #:raise
+ 1
+ #:fontsize
+ -2
+ #:flat))
+ (markup #:null)))))
+ (markup #:null)))
+ input-list key-list))
+
+; Makes a list of number-keys
+(define (make-number-keylist input-list key-list font-size)
+ (map (lambda (x y)
+ (if (< x 1)
+ (markup
+ #:conditional-circle-markup
+ x
+ (markup #:abs-fontsize font-size #:number y))
+ (markup #:null)))
+ input-list
+ key-list))
+
+; Creates a named-key list with a certain alignment
+(define (aligned-text-stencil-function dir hv)
+ (lambda (key-name-list radius fill-list layout props)
+ (interpret-markup
+ layout
+ props
+ (make-general-align-markup
+ X
+ dir
+ ((if hv make-concat-markup make-center-column-markup)
+ (make-name-keylist
+ (map text-fill-translate fill-list)
+ key-name-list
+ (* 12 radius)))))))
+
+(define number-column-stencil
+ (lambda (key-name-list radius fill-list layout props)
+ (interpret-markup
+ layout
+ props
+ (make-general-align-markup
+ Y
+ CENTER
+ (make-general-align-markup
+ X
+ RIGHT
+ (make-override-markup
+ '(baseline-skip . 0)
+ (make-column-markup
+ (make-number-keylist
+ (map text-fill-translate fill-list)
+ key-name-list
+ (* radius 8)))))))))
+
+; Utility function for the left-hand keys
+(define lh-woodwind-text-stencil
+ (aligned-text-stencil-function LEFT #t))
+
+; Utility function for the right-hand keys
+(define rh-woodwind-text-stencil
+ (aligned-text-stencil-function RIGHT #t))
+
+(define octave-woodwind-text-stencil
+ (aligned-text-stencil-function CENTER #f))
+
+;;; Draw rules
+
+(define (rich-group-draw-rule alist target-part change-part)
+ (if
+ (entry-greater-than-x?
+ (map (lambda (key) (assoc-get key alist)) target-part) 3)
+ (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist)
+ alist))
+
+(define (bassoon-midline-rule alist target-part)
+ (if
+ (entry-greater-than-x?
+ (map (lambda (key) (assoc-get key alist)) target-part) 0)
+ (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist)
+ (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist)))
+
+(define (group-draw-rule alist target-part)
+ (rich-group-draw-rule alist target-part target-part))
+
+(define (group-automate-rule alist change-part)
+ (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist))
+
+(define (apply-group-draw-rule-series alist target-part-list)
+ (if (null? target-part-list)
+ alist
+ (apply-group-draw-rule-series
+ (group-draw-rule alist (car target-part-list))
+ (cdr target-part-list))))
+
+;; Extra-offset rules
+
+(define (rich-group-extra-offset-rule alist target-part change-part eos)
+ (if
+ (entry-greater-than-x?
+ (map (lambda (key) (assoc-get key alist)) target-part) 0)
+ (map-selected-alist-keys (lambda (x) eos) change-part alist)
+ alist))
+
+(define (group-extra-offset-rule alist target-part eos)
+ (rich-group-extra-offset-rule alist target-part target-part eos))
+
+(define (uniform-extra-offset-rule alist eos)
+ (map-selected-alist-keys
+ (lambda (x) (if (pair? x) x eos))
+ (assoc-keys alist)
+ alist))
+
+;;; General drawing commands
+
+; Used all the time for a dividing line
+(define (midline-stencil radius thick fill layout props)
+ (make-line-stencil (* thick 2) (* -0.80 radius) 0 (* 0.80 radius) 0))
+
+(define (long-midline-stencil radius thick fill layout props)
+ (make-line-stencil (* thick 2) (* -5.75 radius) 0 (* 0.75 radius) 0))
+
+; Used all the time for a small, between-hole key
+(define little-elliptical-key-stencil (standard-e-stencil 0.75 0.2))
+
+; Used for several upper keys in the clarinet and sax
+(define (upper-key-stencil tailw tailh bodyw bodyh)
+ (let*
+ ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2))))))
+ (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05)))))))
+ (standard-mcs-stencil
+ `((,(xmove 0.7)
+ ,(ymove -0.2)
+ ,(xmove 1.0)
+ ,(ymove -1.0)
+ ,(xmove 0.5)
+ ,(ymove -1.0))
+ (,(xmove 0.2)
+ ,(ymove -1.0)
+ ,(xmove 0.2)
+ ,(ymove -0.2)
+ ,(xmove 0.3)
+ ,(ymove -0.1))
+ (,(+ 0.2 tailw)
+ ,(- -0.05 tailh)
+ ,(+ 0.1 (/ tailw 2))
+ ,(- -0.025 (/ tailh 2))
+ 0.0
+ 0.0))
+ 1.0
+ 1.0)))
+
+; Utility function for the column-hole maker.
+; Returns the left and right degrees for the drawing of a given
+; fill level (1-quarter, 1-half, etc...)
+(define (degree-first-true fill-list left? reverse?)
+ (define (dfl-crawler fill-list os-list left?)
+ (if (car fill-list)
+ ((if left? car cdr) (car os-list))
+ (dfl-crawler (cdr fill-list) (cdr os-list) left?)))
+ (dfl-crawler
+ ((if reverse? reverse identity) fill-list)
+ ((if reverse? reverse identity)
+ '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90)))
+ left?))
+
+; Gets the position of the first (or last if reverse?) element of a list.
+(define (position-true-endpoint in-list reverse?)
+ (define (pte-crawler in-list n)
+ (if (car in-list)
+ n
+ (pte-crawler (cdr in-list) (+ n 1))))
+ ((if reverse? - +)
+ (if reverse? (length in-list) 0)
+ (pte-crawler ((if reverse? reverse identity) in-list) 0)))
+
+; Huge, kind-of-ugly maker of a circle in a column.
+; I think this is the clearest way to write it, though...
+
+(define (column-circle-stencil radius thick fill layout props)
+ (let* ((fill-list (process-fill-value fill)))
+ (cond
+ ((and
+ (list-ref fill-list 0)
+ (not (true-entry? (list-tail fill-list 1)))) ; is it empty?
+ ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
+ ((and
+ (list-ref fill-list 4)
+ (not (true-entry? (list-head fill-list 4)))) ; is it full?
+ ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
+ ((and
+ (list-ref fill-list 0)
+ (list-ref fill-list 4)) ; is it a trill between empty and full?
+ ((standard-e-stencil 1.0 1.0) radius thick fill layout props))
+ (else ;If none of these, it is partially full.
+ (ly:stencil-add
+ ((rich-pe-stencil 1.0 1.0 0 360 identity)
+ radius
+ thick
+ (if (list-ref fill-list 4)
+ (expt (assoc-get 'F HOLE-FILL-LIST) 2)
+ 1)
+ layout
+ props)
+ ((rich-pe-stencil
+ 1.0
+ 1.0
+ (degree-first-true fill-list #t #t)
+ (degree-first-true fill-list #f #t)
+ identity)
+ radius
+ thick
+ (if
+ (true-entry?
+ (list-head fill-list (position-true-endpoint fill-list #t)))
+ (expt (assoc-get 'F HOLE-FILL-LIST) 2)
+ (assoc-get 'F HOLE-FILL-LIST))
+ layout
+ props)
+ (if
+ (= 2 (n-true-entries (list-tail fill-list 1))) ; trill?
+ ((rich-pe-stencil
+ 1.0
+ 1.0
+ (degree-first-true fill-list #t #f)
+ (degree-first-true fill-list #f #f)
+ identity)
+ radius
+ thick
+ (assoc-get 'F HOLE-FILL-LIST)
+ layout
+ props)
+ empty-stencil))))))
+
+(define (variable-column-circle-stencil scaler)
+ (lambda (radius thick fill layout props)
+ (column-circle-stencil (* radius scaler) thick fill layout props)))
+
+; A stencil for ring-column circles that combines two of the above
+(define (ring-column-circle-stencil radius thick fill layout props)
+ (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST)))
+ (ly:stencil-add
+ ((if
+ (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
+ gray-colorize
+ identity)
+ ((standard-e-stencil
+ (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))
+ (* (+ (- 1.0 (* 2 thick)) (/ thick 2))))
+ radius
+ (* (* 4 radius) thick)
+ 1
+ layout
+ props))
+ ((standard-e-stencil 1.0 1.0) radius thick 1 layout props)
+ (column-circle-stencil
+ (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2))
+ thick
+ (*
+ (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST)))
+ (assoc-get 'F HOLE-FILL-LIST)
+ 1)
+ (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
+ (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2))
+ (/ fill (assoc-get 'R HOLE-FILL-LIST))))
+ layout
+ props))
+ (column-circle-stencil radius thick fill layout props)))
+
+;;; Flute family stencils
+
+(define flute-lh-b-key-stencil
+ (standard-mcs-stencil
+ '((0 1.3)
+ (0 1.625 -0.125 1.75 -0.25 1.75)
+ (-0.55 1.75 -0.55 0.95 -0.25 0.7)
+ (0 0.4 0 0.125 0 0))
+ 2
+ 1.55))
+
+(define flute-lh-bes-key-stencil
+ (standard-mcs-stencil
+ '((0 1.3)
+ (0 1.625 -0.125 1.75 -0.25 1.75)
+ (-0.55 1.75 -0.55 0.95 -0.25 0.7)
+ (0 0.4 0 0.125 0 0))
+ 2.0
+ 1.3))
+
+(define (flute-lh-gis-rh-bes-key-stencil deg)
+ (rich-mcs-stencil
+ '((0.1 0.1 0.2 0.4 0.3 0.6)
+ (0.3 1.0 0.8 1.0 0.8 0.7)
+ (0.8 0.3 0.5 0.3 0 0))
+ 1.0
+ 1.0
+ (lambda (stencil) (ly:stencil-rotate stencil deg 0 0))))
+
+(define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0))
+
+(define flute-rh-bes-key-stencil (flute-lh-gis-rh-bes-key-stencil 200))
+
+(define flute-rh-d-key-stencil little-elliptical-key-stencil)
+
+(define flute-rh-dis-key-stencil little-elliptical-key-stencil)
+
+(define flute-rh-ees-key-stencil
+ (standard-mcs-stencil
+ '((0.8 0) (1.1 0 1.1 0.75 0.7 0.75) (0.5 0.75) (0.15 0.75 0.1 0.2 0 0))
+ -2.38
+ 1.4))
+
+(define (piccolo-rh-x-key-stencil radius thick fill layout props)
+ (interpret-markup
+ layout
+ props
+ (make-general-align-markup
+ Y
+ DOWN
+ (make-concat-markup
+ (make-name-keylist
+ `(,(text-fill-translate fill))
+ '(("X" . #f))
+ (* 9 radius))))))
+
+(define flute-lower-row-stretch 1.4)
+
+(define flute-rh-cis-key-stencil
+ (standard-mcs-stencil
+ '((0 0.75) (-0.8 0.75 -0.8 0 0 0))
+ flute-lower-row-stretch
+ flute-lower-row-stretch))
+
+(define flute-rh-c-key-stencil
+ (standard-mcs-stencil
+ '((0 0.75) (0.4 0.75) (0.4 0) (0 0))
+ flute-lower-row-stretch
+ flute-lower-row-stretch))
+
+(define flute-rh-b-key-stencil
+ (standard-mcs-stencil
+ '((0 0.75) (0.25 0.75) (0.25 0) (0 0))
+ flute-lower-row-stretch
+ flute-lower-row-stretch))
+
+(define flute-rh-gz-key-stencil
+ (rich-mcs-stencil
+ '((0.1 0.1 0.4 0.2 0.6 0.3)
+ (1.0 0.3 1.0 0.8 0.7 0.8)
+ (0.3 0.8 0.3 0.5 0 0))
+ flute-lower-row-stretch
+ flute-lower-row-stretch
+ (lambda (stencil) (ly:stencil-rotate stencil 160 0 0))))
+
+;;; Shared oboe/clarinet stencils
+
+(define (oboe-lh-gis-lh-low-b-key-stencil gis?)
+ (let*
+ ((x 1.2)
+ (y 0.4)
+ (scaling-factor 1.7)
+ (up-part
+ (car
+ (split-bezier
+ `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0))
+ 0.8)))
+ (down-part
+ (cdr
+ (split-bezier
+ `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
+ 0.2))))
+ (if gis?
+ (standard-mcs-stencil
+ (append
+ (append
+ `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0))
+ (map (lambda (l)
+ (flatten-list
+ (map (lambda (x)
+ (coord-translate
+ (coord-rotate x (atan (/ y (* 2 0.25))))
+ '(1.0 . 0)))
+ l)))
+ `(((0 . ,y) (,x . ,y) (,x . 0))
+ ((,x . ,(- y)) (0 . ,(- y)) (0 . 0)))))
+ `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0)))
+ scaling-factor
+ scaling-factor)
+ (standard-mcs-stencil
+ (map (lambda (l)
+ (flatten-list
+ (map (lambda (x)
+ (coord-rotate x (atan (/ y (* 2 0.25)))))
+ l)))
+ `(,(list-tail up-part 1)
+ ,(list-head down-part 1)
+ ,(list-tail down-part 1)))
+ (- scaling-factor)
+ (- scaling-factor)))))
+
+(define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t))
+
+(define oboe-lh-low-b-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #f))
+
+(define (oboe-lh-ees-lh-bes-key-stencil ees?)
+ (standard-mcs-stencil
+ `((0 1.5)
+ (0 1.625 -0.125 1.75 -0.25 1.75)
+ (-0.5 1.75 -0.5 0.816 -0.25 0.5)
+ (0 0.25 0 0.125 0 0)
+ (0 ,(if ees? -0.6 -0.3)))
+ (* (if ees? -1.0 1.0) -1.8)
+ 1.8))
+
+(define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t))
+
+(define oboe-lh-bes-key-stencil (oboe-lh-ees-lh-bes-key-stencil #f))
+
+;;; Oboe family stencils
+
+(define (oboe-lh-octave-key-stencil long?)
+ (let* ((h (if long? 1.4 1.2)))
+ (standard-mcs-stencil
+ `((-0.4 0 -0.4 1.0 -0.1 1.0)
+ (-0.1 ,h)
+ (0.1 ,h)
+ (0.1 1.0)
+ (0.4 1.0 0.4 0 0 0))
+ 2.0
+ 2.0)))
+
+(define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f))
+
+(define oboe-lh-II-key-stencil (oboe-lh-octave-key-stencil #f))
+
+(define oboe-lh-III-key-stencil (oboe-lh-octave-key-stencil #t))
+
+(define oboe-lh-b-key-stencil (standard-e-stencil 0.6 0.8))
+
+(define oboe-lh-d-key-stencil little-elliptical-key-stencil)
+
+(define oboe-lh-cis-key-stencil little-elliptical-key-stencil)
+
+(define oboe-lh-f-key-stencil (standard-e-stencil 0.5 1.0))
+
+(define oboe-rh-a-key-stencil (standard-e-stencil 1.0 0.45))
+
+(define oboe-rh-gis-key-stencil (standard-e-stencil 0.45 1.2))
+
+(define oboe-rh-d-key-stencil little-elliptical-key-stencil)
+
+(define oboe-rh-f-key-stencil little-elliptical-key-stencil)
+
+(define (oboe-rh-c-rh-ees-key-stencil c?)
+ (rich-mcs-stencil
+ '((1.0 0.0 1.0 0.70 1.5 0.70)
+ (2.25 0.70 2.25 -0.4 1.5 -0.4)
+ (1.0 -0.4 1.0 0 0 0)
+ (-0.15 0))
+ 2.0
+ 1.4
+ (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0))))
+
+(define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil)
+
+(define oboe-rh-c-key-stencil (oboe-rh-c-rh-ees-key-stencil #t))
+
+(define oboe-rh-cis-key-stencil
+ (rich-mcs-stencil
+ '((0.6 0.0 0.6 0.50 1.25 0.50)
+ (2.25 0.50 2.25 -0.4 1.25 -0.4)
+ (0.6 -0.4 0.6 0 0 0))
+ -0.9
+ 1.0
+ (lambda (stencil) (ly:stencil-rotate stencil 0 0 0))))
+
+(define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f))
+
+;;; Clarinet family stencils
+
+(define clarinet-lh-thumb-key-stencil
+ (variable-column-circle-stencil 0.9))
+
+(define clarinet-lh-R-key-stencil
+ (let* ((halfbase (cos (/ PI 10)))
+ (height (*
+ halfbase
+ (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
+ (standard-mcs-stencil
+ `(
+ (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0)
+ (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height)
+ (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0))
+ 0.9
+ 0.9)))
+
+(define (clarinet-lh-a-key-stencil radius thick fill layout props)
+ (let* ((width 0.4) (height 0.75) (linelen 0.45))
+ (ly:stencil-add
+ ((standard-e-stencil width height) radius thick fill layout props)
+ (ly:stencil-translate
+ (make-line-stencil thick 0 0 0 (* linelen radius))
+ (cons 0 (* height radius))))))
+
+(define clarinet-lh-gis-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
+
+(define clarinet-lh-ees-key-stencil little-elliptical-key-stencil)
+
+(define clarinet-lh-cis-key-stencil oboe-lh-gis-key-stencil)
+
+(define clarinet-lh-f-key-stencil oboe-lh-low-b-key-stencil)
+
+(define clarinet-lh-e-key-stencil oboe-lh-ees-key-stencil)
+
+(define clarinet-lh-fis-key-stencil oboe-lh-bes-key-stencil)
+
+(define clarinet-lh-d-key-stencil (standard-e-stencil 1.0 0.4))
+
+(define clarinet-rh-low-c-key-stencil
+ (standard-mcs-stencil
+ '((0.0 1.5)
+ (0.0 2.5 -1.0 2.5 -1.0 0.75)
+ (-1.0 0.1 0.0 0.25 0.0 0.3)
+ (0.0 0.0))
+ 0.8
+ 0.8))
+
+(define clarinet-rh-low-cis-key-stencil
+ (standard-mcs-stencil
+ '((0.0 1.17)
+ (0.0 1.67 -1.0 1.67 -1.0 0.92)
+ (-1.0 0.47 0.0 0.52 0.0 0.62)
+ (0.0 0.0))
+ 0.8
+ 0.8))
+
+(define clarinet-rh-low-d-key-stencil
+ (standard-mcs-stencil
+ '((0.0 1.05)
+ (0.0 1.55 -1.0 1.55 -1.0 0.8)
+ (-1.0 0.35 0.0 0.4 0.0 0.5)
+ (0.0 0.0))
+ 0.8
+ 0.8))
+
+(define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25))
+
+(define clarinet-rh-two-key-stencil clarinet-rh-one-key-stencil)
+
+(define clarinet-rh-three-key-stencil clarinet-rh-one-key-stencil)
+
+(define clarinet-rh-four-key-stencil clarinet-rh-one-key-stencil)
+
+(define clarinet-rh-b-key-stencil little-elliptical-key-stencil)
+
+; cl low-rh values
+(define CL-RH-HAIR 0.09)
+(define CL-RH-H-STRETCH 2.7)
+(define CL-RH-V-STRETCH 0.9)
+
+; TODO
+; there is some unnecessary information duplication here.
+; need a way to control all of the below stencils so that if one
+; changes, all change...
+
+(define clarinet-rh-fis-key-stencil
+ (standard-mcs-stencil
+ `(,(bezier-head-for-stencil
+ '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
+ 0.5)
+ ,(bezier-head-for-stencil
+ '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
+ 0.5)
+ (1.0 1.0 0.0 1.0 0.0 0.0))
+ CL-RH-H-STRETCH
+ CL-RH-V-STRETCH))
+
+(define clarinet-rh-e-key-stencil
+ (standard-mcs-stencil
+ '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0))
+ CL-RH-H-STRETCH
+ CL-RH-V-STRETCH))
+
+(define clarinet-rh-ees-key-stencil
+ (standard-mcs-stencil
+ `(,(bezier-head-for-stencil
+ '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
+ 0.5)
+ ,(bezier-head-for-stencil
+ '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
+ 0.5)
+ ,(bezier-head-for-stencil
+ `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5))
+ 0.5)
+ ,(bezier-head-for-stencil
+ `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75))
+ 0.5))
+ CL-RH-H-STRETCH
+ CL-RH-V-STRETCH))
+
+(define clarinet-rh-gis-key-stencil clarinet-rh-e-key-stencil)
+
+(define bass-clarinet-rh-f-key-stencil
+ (standard-mcs-stencil
+ `(,(bezier-head-for-stencil
+ '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0))
+ 0.5)
+ ,(bezier-head-for-stencil
+ '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75))
+ 0.5)
+ (1.0 1.0 0.0 1.0 0.0 0.0))
+ CL-RH-H-STRETCH
+ (- CL-RH-V-STRETCH)))
+
+(define low-bass-clarinet-rh-f-key-stencil clarinet-rh-ees-key-stencil)
+
+(define clarinet-rh-d-key-stencil clarinet-rh-e-key-stencil)
+
+;;; Saxophone family stencils
+
+(define saxophone-lh-ees-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
+
+(define saxophone-lh-f-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
+
+(define saxophone-lh-d-key-stencil (upper-key-stencil 0.0 0.0 1.3 2.0))
+
+(define saxophone-lh-front-f-key-stencil (standard-e-stencil 0.7 0.7))
+
+(define saxophone-lh-bes-key-stencil (standard-e-stencil 0.5 0.5))
+
+(define saxophone-lh-T-key-stencil (standard-e-stencil 0.75 0.75))
+
+(define saxophone-lh-gis-key-stencil
+ (standard-mcs-stencil
+ '((0.0 0.4)
+ (0.0 0.8 3.0 0.8 3.0 0.4)
+ (3.0 0.0)
+ (3.0 -0.4 0.0 -0.4 0.0 0.0))
+ 0.8
+ 0.8))
+
+(define (saxophone-lh-b-cis-key-stencil flip?)
+ (standard-mcs-stencil
+ '((0.0 1.0)
+ (0.4 1.0 0.8 0.9 1.35 0.8)
+ (1.35 0.0)
+ (0.0 0.0))
+ (* (if flip? -1 1) 0.8)
+ 0.8))
+
+(define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t))
+
+(define saxophone-lh-b-key-stencil (saxophone-lh-b-cis-key-stencil #f))
+
+(define saxophone-lh-low-bes-key-stencil
+ (standard-mcs-stencil
+ '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
+ 0.8
+ 0.8))
+
+(define (saxophone-rh-side-key-stencil width height)
+ (standard-mcs-stencil
+ `((0.0 ,height)
+ (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15))
+ (,(- width 0.15) ,(+ height 0.15))
+ (,(- width 0.1)
+ ,(+ height 0.1)
+ ,(- width 0.05)
+ ,(+ height 0.05)
+ ,width
+ ,height)
+ (,width 0.0)
+ (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15)
+ (0.15 -0.15)
+ (0.1 -0.1 0.05 -0.05 0.0 0.0))
+ 1.0
+ 1.0))
+
+(define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2))
+
+(define saxophone-rh-c-key-stencil (saxophone-rh-side-key-stencil 0.9 0.6))
+
+(define saxophone-rh-bes-key-stencil (saxophone-rh-side-key-stencil 0.9 0.45))
+
+(define saxophone-rh-high-fis-key-stencil
+ (standard-mcs-stencil
+ (append
+ '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
+ (map (lambda (l)
+ (flatten-list
+ (map (lambda (x)
+ (coord-rotate x (atan (* -1 (/ PI 6)))))
+ l)))
+ '(((0.6 . -1.0))
+ ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
+ ((0.0 . 0.0)))))
+ 0.75
+ 0.75))
+
+(define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5))
+
+(define saxophone-rh-ees-key-stencil (standard-e-stencil 1.2 0.5))
+
+(define saxophone-rh-low-c-key-stencil
+ (standard-mcs-stencil
+ '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
+ 0.8
+ 0.8))
+
+(define (saxophone-lh-low-a-key-stencil radius thick fill layout props)
+ (interpret-markup
+ layout
+ props
+ (make-general-align-markup
+ Y
+ DOWN
+ (make-concat-markup
+ (make-name-keylist
+ `(,(text-fill-translate fill))
+ '(("lowA" . #f))
+ (* 9 radius))))))
+
+;;; Bassoon family stencils
+
+(define (bassoon-bend-info-maker height gap cut)
+ (let* (
+ (first-bezier
+ (flatten-list
+ (car
+ (split-bezier
+ `((0.0 . ,(+ height gap))
+ (0.0 . ,(+ height (+ gap 1.0)))
+ (1.0 . ,(+ height (+ gap 2.0)))
+ (2.0 . ,(+ height (+ gap 2.0))))
+ cut))))
+ (second-bezier
+ (flatten-list
+ (reverse
+ (car
+ (split-bezier
+ `((1.0 . ,height)
+ (1.0 . ,(+ 0.5 height))
+ (1.5 . ,(+ 1.0 height))
+ (2.0 . ,(+ 1.0 height)))
+ cut)))))
+ (slope-offset1
+ (get-slope-offset
+ `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5))
+ `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7))))
+ (slope-offset2
+ (get-slope-offset
+ `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1))
+ `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3)))))
+ (list first-bezier second-bezier slope-offset1 slope-offset2)))
+
+(define
+ (make-tilted-portion
+ first-bezier
+ second-bezier
+ slope-offset1
+ slope-offset2
+ keylen
+ bezier?)
+ (append
+ `((,(+ keylen (list-ref first-bezier 6))
+ ,(+
+ (*
+ (car slope-offset1)
+ (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1))))
+ ((if bezier? (lambda (x) `(,(apply append x))) identity)
+ `((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
+ ,(+
+ (*
+ (car slope-offset1)
+ (+ (+ keylen 1.75) (list-ref first-bezier 6)))
+ (cdr slope-offset1)))
+ (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
+ ,(+
+ (*
+ (car slope-offset2)
+ (+ (+ keylen 1.75) (list-ref second-bezier 0)))
+ (cdr slope-offset2)))
+ (,(+ keylen (list-ref second-bezier 0))
+ ,(+
+ (* (car slope-offset2) (+ keylen (list-ref second-bezier 0)))
+ (cdr slope-offset2)))))
+ `(,(list-head second-bezier 2))))
+
+(define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?)
+ (let* ((info-list (bassoon-bend-info-maker height gap cut))
+ (first-bezier (car info-list))
+ (second-bezier (cadr info-list))
+ (slope-offset1 (caddr info-list))
+ (slope-offset2 (cadddr info-list)))
+ (rich-mcs-stencil
+ (append
+ `((0.0 ,(+ height gap))
+ ,(list-tail first-bezier 2))
+ (make-tilted-portion
+ first-bezier
+ second-bezier
+ slope-offset1
+ slope-offset2
+ keylen
+ bezier?)
+ `(,(list-tail second-bezier 2)
+ (1.0 0.0)
+ (0.0 0.0)))
+ d1
+ d2
+ proc)))
+
+(define (bassoon-uber-key-stencil height gap cut keylen d1 d2)
+ (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 identity #t))
+
+(define bassoon-cc-one-key-stencil (standard-e-stencil 1.5 0.8))
+
+(define bassoon-lh-he-key-stencil little-elliptical-key-stencil)
+
+(define bassoon-lh-hees-key-stencil little-elliptical-key-stencil)
+
+(define bassoon-lh-ees-key-stencil
+ (rich-e-stencil
+ 1.2
+ 0.6
+ (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
+
+(define bassoon-lh-cis-key-stencil
+ (rich-e-stencil
+ 1.0
+ 0.5
+ (lambda (stencil) (ly:stencil-rotate stencil 30 0 0))))
+
+(define bassoon-lh-lbes-key-stencil
+ (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6))
+
+(define bassoon-lh-lb-key-stencil
+ (bassoon-uber-key-stencil 2.0 0.5 0.9 1.2 0.6 -0.6))
+
+(define bassoon-lh-lc-key-stencil
+ (rich-pe-stencil 1.0 1.0 135 315 identity))
+
+(define bassoon-lh-ld-key-stencil
+ (standard-mcs-stencil
+ '((-0.8 4.0 1.4 4.0 0.6 0.0)
+ (0.5 -0.5 0.5 -0.8 0.6 -1.0)
+ (0.7 -1.2 0.8 -1.3 0.8 -1.8)
+ (0.5 -1.8)
+ (0.5 -1.4 0.4 -1.2 0.3 -1.1)
+ (0.2 -1.0 0.1 -0.5 0.0 0.0))
+ 1.0
+ 1.0))
+
+(define bassoon-lh-d-flick-key-stencil
+ (let ((height 3.0))
+ (standard-mcs-stencil
+ `((0.0 ,height)
+ (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8))
+ (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0))
+ (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3))
+ (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
+ (0.4 0.0)
+ (0.0 0.0))
+ -1.0
+ -1.0)))
+
+(define bassoon-lh-c-flick-key-stencil
+ (let ((height 3.0))
+ (standard-mcs-stencil
+ `((0.0 ,height)
+ (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8))
+ (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0))
+ (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3))
+ (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1))
+ (0.4 0.0)
+ (0.0 0.0))
+ -1.0
+ -1.0)))
+
+(define bassoon-lh-a-flick-key-stencil
+ (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5))
+
+(define bassoon-lh-thumb-cis-key-stencil
+ (bassoon-uber-key-stencil 1.5 1.5 0.6 0.6 -0.6 0.6))
+
+(define bassoon-lh-whisper-key-stencil (variable-column-circle-stencil 0.7))
+
+(define bassoon-rh-cis-key-stencil
+ (rich-bassoon-uber-key-stencil
+ 1.1
+ 1.5
+ 0.9
+ 0.3
+ 0.5
+ 0.5
+ (lambda (stencil) (ly:stencil-rotate stencil -76 0 0))
+ #t))
+
+(define bassoon-rh-bes-key-stencil little-elliptical-key-stencil)
+
+(define bassoon-rh-fis-key-stencil
+ (rich-bassoon-uber-key-stencil 0.5 1.0 0.8 1.5 -0.7 0.7 identity #f))
+
+(define bassoon-rh-f-key-stencil
+ (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5)
+ (info-list (bassoon-bend-info-maker height gap cut))
+ (first-bezier (car info-list))
+ (second-bezier (cadr info-list))
+ (slope-offset1 (caddr info-list))
+ (slope-offset2 (cadddr info-list)))
+ (standard-mcs-stencil
+ (append
+ (map
+ (lambda (l)
+ (rotunda-map
+ -
+ l
+ (list-tail first-bezier 6)))
+ (make-tilted-portion
+ first-bezier
+ second-bezier
+ slope-offset1
+ slope-offset2
+ keylen
+ #t))
+ '((0.0 0.0)))
+ -0.7
+ 0.7)))
+
+(define bassoon-rh-gis-key-stencil
+ (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7))
+
+(define bassoon-rh-thumb-bes-key-stencil
+ (bassoon-uber-key-stencil 1.0 1.0 0.9 1.0 0.7 0.7))
+
+(define bassoon-rh-thumb-e-key-stencil (variable-column-circle-stencil 0.7))
+
+(define bassoon-rh-thumb-fis-key-stencil
+ (bassoon-uber-key-stencil 1.0 1.2 0.9 1.0 0.7 0.7))
+
+(define bassoon-rh-thumb-gis-key-stencil
+ (bassoon-uber-key-stencil 1.2 0.8 0.9 0.4 0.7 0.7))
\ No newline at end of file
--- /dev/null
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2010 Mike Solomon <mikesol@stanfordalumni.org>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
+
+;; Constants
+
+(define CENTRAL-COLUMN-HOLE-PLACEMENTS '((one . (0.0 . 6.5))
+ (two . (0.0 . 5.5))
+ (three . (0.0 . 4.5))
+ (four . (0.0 . 3.0))
+ (five . (0.0 . 2.0))
+ (six . (0.0 . 1.0))))
+
+(define CENTRAL-COLUMN-HOLE-LIST (map car CENTRAL-COLUMN-HOLE-PLACEMENTS))
+(define CENTRAL-COLUMN-HOLE-H-LIST (cons 'h CENTRAL-COLUMN-HOLE-LIST))
+
+;; Utility functions
+
+(define (return-1 x) 1.0)
+
+(define (make-spreadsheet parameter-list)
+ "Makes a spreadsheet function with columns of parameter-list.
+ This function can then be filled with rows.
+ For example:
+ @code{guile> ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6)))}
+ @code{(((foo . 1) (bar . 2)) ((foo . 3) (bar . 4)) ((foo . 5) (bar . 6)))}"
+ (lambda (ls)
+ (map (lambda (list-to-translate)
+ (map (lambda (name element)
+ `(,name . ,element))
+ parameter-list
+ list-to-translate))
+ ls)))
+
+(define (get-spreadsheet-column column spreadsheet)
+ "Gets all the values in @code{column} form @code{spreadsheet}
+ made by @{make-spreadsheet}.
+ For example:
+ @code{guile> (get-spreadsheet-column 'bar ((make-spreadsheet '(foo bar)) '((1 2) (3 4) (5 6))))}
+ @code{(2 4 6)}"
+ (map (lambda (row) (assoc-get column row)) spreadsheet))
+
+(define (make-named-spreadsheet parameter-list)
+ "Makes a named spreadsheet function with columns of parameter-list.
+ This function can then be filled with named rows
+ For example:
+ @code{guile> ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6))))}
+ @code{((x (foo . 1) (bar . 2)) (y (foo . 3) (bar . 4)) (z (foo . 5) (bar . 6)))}"
+ (lambda (ls)
+ (map (lambda (list-to-translate)
+ `(,(list-ref list-to-translate 0)
+ . ,(map (lambda (name element)
+ `(,name . ,element))
+ parameter-list
+ (list-tail list-to-translate 1))))
+ ls)))
+
+(define (get-named-spreadsheet-column column spreadsheet)
+ "Gets all the values in @code{column} form @code{spreadsheet}
+ made by @{make-named-spreadsheet}.
+ For example:
+ @code{guile> (get-spreadsheet-column 'bar ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6)))))}
+ @code{((x . 2) (y . 4) (z . 6))}"
+ (map
+ (lambda (row) (cons (car row) (assoc-get column (cdr row))))
+ spreadsheet))
+
+(define make-key-alist
+ (make-named-spreadsheet '(name offset graphical textual)))
+
+(define (simple-stencil-alist stencil offset)
+ "A stencil alist that contains one and only one stencil.
+ Shorthand used repeatedly in various instruments."
+ `((stencils . (,stencil))
+ (offset . ,offset)
+ (textual? . #f)
+ (xy-scale-function . (,return-1 . ,return-1))))
+
+(define (make-central-column-hole-addresses keys)
+ "Takes @code{keys} and ascribes them to the central column."
+ (map
+ (lambda (key) `(central-column . ,key))
+ keys))
+
+(define (make-key-symbols hand)
+ "Takes @code{hand} and ascribes @code{key} to it."
+ (lambda (keys)
+ (map (lambda (key) `(,hand . ,key))
+ keys)))
+
+(define make-left-hand-key-addresses (make-key-symbols 'left-hand))
+
+(define make-right-hand-key-addresses (make-key-symbols 'right-hand))
+
+;; Flute assembly instructions
+
+(define flute-change-points
+ ((make-named-spreadsheet '(piccolo flute flute-b-extension))
+ `((bottom-group-key-names
+ . (((x
+ . ((offset . (-0.45 . -1.05))
+ (stencil . ,piccolo-rh-x-key-stencil)
+ (text? . ("X" . #f))
+ (complexity . trill))))
+ ((cis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-rh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (c
+ . ((offset . (0.3 . 0.0))
+ (stencil . ,flute-rh-c-key-stencil)
+ (text? . ("C" . #f))
+ (complexity . trill)))
+ (gz
+ . ((offset . (0.0 . -1.2))
+ (stencil . ,flute-rh-gz-key-stencil)
+ (text? . ("gz" . #f))
+ (complexity . trill))))
+ ((cis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-rh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (c
+ . ((offset . (0.3 . 0.0))
+ (stencil . ,flute-rh-c-key-stencil)
+ (text? . ("C" . #f))
+ (complexity . trill)))
+ (b
+ . ((offset . (1.0 . 0.0))
+ (stencil . ,flute-rh-b-key-stencil)
+ (text? . ("B" . #f))
+ (complexity . trill)))
+ (gz
+ . ((offset . (0.0 . -1.2))
+ (stencil . ,flute-rh-gz-key-stencil)
+ (text? . ("gz" . #f))
+ (complexity . trill))))))
+ (bottom-group-graphical-stencil
+ . (((right-hand . ees) (right-hand . x))
+ ,(make-right-hand-key-addresses '(ees cis c gz))
+ ,(make-right-hand-key-addresses '(ees cis c b gz))))
+ (bottom-group-graphical-draw-instruction
+ . (((right-hand . ees))
+ ,(make-right-hand-key-addresses '(ees cis c))
+ ,(make-right-hand-key-addresses '(ees cis c b))))
+ (bottom-group-special-key-instruction
+ . ((,rich-group-draw-rule ((right-hand . x)) ((right-hand . ees)))
+ (,rich-group-draw-rule ((right-hand . gz))
+ ,(make-right-hand-key-addresses
+ '(ees cis c)))
+ (,rich-group-draw-rule ((right-hand . gz))
+ ,(make-right-hand-key-addresses
+ '(ees cis c b)))))
+ (bottom-group-text-stencil
+ . (,(make-right-hand-key-addresses '(bes d dis ees x))
+ ,(make-right-hand-key-addresses '(bes d dis ees cis c gz))
+ ,(make-right-hand-key-addresses '(bes d dis ees cis c b gz)))))))
+
+(define (generate-flute-family-entry flute-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column
+ flute-name
+ flute-change-points)))
+ `(,flute-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))))
+ (left-hand
+ . ((bes
+ . ((offset . (0.5 . 1.8))
+ (stencil . ,flute-lh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (b
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-lh-b-key-stencil)
+ (text? . ("B" . #f))
+ (complexity . trill)))
+ (gis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-lh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))))
+ (right-hand
+ . ,(append `((bes
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-rh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (d
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-rh-d-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill)))
+ (dis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,flute-rh-dis-key-stencil)
+ (text? . ("D" . 1))
+ (complexity . trill)))
+ (ees
+ . ((offset . (1.5 . 1.3))
+ (stencil . ,flute-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill))))
+ (assoc-get 'bottom-group-key-names change-points)))))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils . ((left-hand . bes) (left-hand . b)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-1.5 . 6.5)))
+ ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0))
+ ,(simple-stencil-alist '(right-hand . bes) '(-1.75 . 3.05))
+ ,(simple-stencil-alist '(right-hand . d) '(-1.0 . 2.5))
+ ,(simple-stencil-alist '(right-hand . dis) '(-1.0 . 1.5))
+ ((stencils
+ . ,(assoc-get 'bottom-group-graphical-stencil
+ change-points))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (0.0 . -0.6)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (((left-hand . bes) (left-hand . b))
+ ,(assoc-get 'bottom-group-graphical-draw-instruction
+ change-points)))
+ ,(assoc-get 'bottom-group-special-key-instruction
+ change-points)
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils . ,(make-left-hand-key-addresses '(bes b gis)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 3.75)))
+ ((stencils . ,(assoc-get 'bottom-group-text-stencil
+ change-points))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses '(bes b gis))
+ ,(assoc-get 'bottom-group-text-stencil change-points)))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;;; Tin whistle assembly instructions
+
+(define tin-whistle-change-points
+ ((make-named-spreadsheet '(tin-whistle)) '()))
+
+(define (generate-tin-whistle-family-entry tin-whistle-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column tin-whistle-name tin-whistle-change-points)))
+ `(,tin-whistle-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))))
+ (left-hand . ())
+ (right-hand . ())))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils .
+ (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-H-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;;; Oboe assembly instructions
+
+(define oboe-change-points
+ ((make-named-spreadsheet '(oboe)) '()))
+
+(define (generate-oboe-family-entry oboe-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column oboe-name oboe-change-points)))
+ `(,oboe-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (h
+ . ((offset . (0.0 . 6.25))
+ (stencil . ,(variable-column-circle-stencil 0.4))
+ (text? . #f)
+ (complexity . trill)))))
+ (left-hand
+ . ((I
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-lh-I-key-stencil)
+ (text? . ("I" . #f))
+ (complexity . trill)))
+ (III
+ . ((offset . (0.0 . 2.6))
+ (stencil . ,oboe-lh-III-key-stencil)
+ (text? . ("III" . #f))
+ (complexity . trill)))
+ (II
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-lh-II-key-stencil)
+ (text? . ("II" . #f))
+ (complexity . trill)))
+ (b
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-lh-b-key-stencil)
+ (text? . ("B" . #f))
+ (complexity . trill)))
+ (d
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-lh-d-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill)))
+ (cis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-lh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (gis
+ . ((offset . (-0.85 . 0.2))
+ (stencil . ,oboe-lh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (ees
+ . ((offset . (2.05 . -3.65))
+ (stencil . ,oboe-lh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (low-b
+ . ((offset . (3.6 . 0.5))
+ (stencil . ,oboe-lh-low-b-key-stencil)
+ (text? . ("b" . #f))
+ (complexity . trill)))
+ (bes
+ . ((offset . (2.25 . -4.15))
+ (stencil . ,oboe-lh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (f
+ . ((offset . (2.15 . -3.85))
+ (stencil . ,oboe-lh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))))
+ (right-hand
+ . ((a
+ . ((offset . (1.5 . 1.2))
+ (stencil . ,oboe-rh-a-key-stencil)
+ (text? . ("A" . #f))
+ (complexity . trill)))
+ (gis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-rh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (d
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-rh-d-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill)))
+ (f
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-rh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))
+ (banana
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-rh-banana-key-stencil)
+ (text? . ("ban" . #f))
+ (complexity . trill)))
+ (c
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,oboe-rh-c-key-stencil)
+ (text? . ("C" . #f))
+ (complexity . trill)))
+ (cis
+ . ((offset . (3.8 . -0.6))
+ (stencil . ,oboe-rh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (ees
+ . ((offset . (0.0 . -1.8))
+ (stencil . ,oboe-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))))))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-H-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils . ((left-hand . I) (left-hand . III)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-2.5 . 6.5)))
+ ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0))
+ ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0))
+ ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0))
+ ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0))
+ ((stencils
+ . ,(make-left-hand-key-addresses '(gis bes low-b ees f)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (0.0 . 3.9)))
+ ((stencils .
+ ,(make-right-hand-key-addresses '(a gis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-3.5 . 3.5)))
+ ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5))
+ ,(simple-stencil-alist '(right-hand . f) '(-1.0 . 1.5))
+ ,(simple-stencil-alist '(right-hand . banana) '(1.7 . 1.0))
+ ((stencils . ,(make-right-hand-key-addresses '(c cis ees)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-3.4 . 0.3)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (((right-hand . a) (right-hand . gis))
+ ,(make-left-hand-key-addresses '(gis bes low-b ees))
+ ,(make-right-hand-key-addresses '(cis c ees))))
+ (,rich-group-draw-rule
+ ((left-hand . III))
+ ((left-hand . I)))
+ (,rich-group-draw-rule
+ ((left-hand . f))
+ ,(make-left-hand-key-addresses '(gis bes low-b ees)))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,rich-group-extra-offset-rule
+ ((central-column . h)) ((central-column . one)) (0.0 . 0.8))
+ (,uniform-extra-offset-rule (0.0 . 0.0))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils .
+ (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-H-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils . ,(make-left-hand-key-addresses '(III I)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (-2.8 . 7.0)))
+ ((stencils . ,(make-left-hand-key-addresses '(II)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (2.2 . 7.0)))
+ ((stencils
+ . ,(make-left-hand-key-addresses
+ '(b d cis gis ees low-b bes f)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 3.75)))
+ ((stencils
+ . ,(make-right-hand-key-addresses
+ '(a gis d f banana c cis ees)))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f))
+ ,(make-left-hand-key-addresses '(III I))
+ ,(make-right-hand-key-addresses '(a gis d f banana c cis ees))))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,rich-group-extra-offset-rule
+ ((central-column . h))
+ ((central-column . one))
+ (0.0 . 0.8))
+ (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;; Clarinet assembly instructions
+
+(define clarinet-change-points
+ ((make-named-spreadsheet '(clarinet bass-clarinet low-bass-clarinet))
+ `((bottom-group-key-names
+ . (()
+ ((f
+ . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,bass-clarinet-rh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill))))
+ ((f
+ . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,low-bass-clarinet-rh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))
+ (d
+ . ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* -1 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-d-key-stencil)
+ (text? . ("d" . #f))
+ (complexity . trill)))
+ (low-cis
+ . ((offset . (0.0 . 1.4))
+ (stencil . ,clarinet-rh-low-cis-key-stencil)
+ (text? . ("c" . 1))
+ (complexity . trill)))
+ (low-d
+ . ((offset . (0.0 . 2.4))
+ (stencil . ,clarinet-rh-low-d-key-stencil)
+ (text? . ("d" . #f))
+ (complexity . trill)))
+ (low-c
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,clarinet-rh-low-c-key-stencil)
+ (text? . ("c" . #f))
+ (complexity . trill))))))
+ (left-extra-key-names
+ . (()
+ ()
+ ((d
+ . ((offset . (4.0 . -0.8))
+ (stencil . ,clarinet-lh-d-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill))))))
+ (right-thumb-group
+ . (()
+ ()
+ (((stencils
+ . ,(make-right-hand-key-addresses '(low-c low-cis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-1.3 . 4.0))))))
+ (low-left-hand-key-addresses
+ . (,(make-left-hand-key-addresses '(cis f e fis))
+ ,(make-left-hand-key-addresses '(cis f e fis))
+ ,(make-left-hand-key-addresses '(cis f e fis d))))
+ (all-left-hand-key-addresses
+ . (,(make-left-hand-key-addresses '(a gis ees cis f e fis))
+ ,(make-left-hand-key-addresses '(a gis ees cis f e fis))
+ ,(make-left-hand-key-addresses '(a gis ees cis f e fis d))))
+ (low-key-group
+ . (()
+ ()
+ (,(make-right-hand-key-addresses '(low-c low-cis)))))
+ (low-rich-draw-rules
+ . (()
+ ()
+ ((,rich-group-draw-rule
+ ((left-hand . d))
+ ,(make-left-hand-key-addresses '(cis f e fis)))
+ (,rich-group-draw-rule
+ ((right-hand . low-d))
+ ((right-hand . low-cis) (right-hand . low-c))))))
+ (low-extra-offset-rule
+ . (()
+ ()
+ ((,rich-group-extra-offset-rule
+ ,(make-right-hand-key-addresses '(low-c low-d low-cis))
+ ,(make-right-hand-key-addresses '(one two three four))
+ (-0.5 . -0.7)))))
+ (bottom-right-group-key-addresses
+ . (,(make-right-hand-key-addresses '(fis e ees gis))
+ ,(make-right-hand-key-addresses '(fis e ees gis f))
+ ,(make-right-hand-key-addresses '(fis e ees gis f d))))
+ (right-hand-key-addresses
+ . (,(make-right-hand-key-addresses '(fis e ees gis))
+ ,(make-right-hand-key-addresses '(fis e ees gis f))
+ ,(make-right-hand-key-addresses
+ '(low-d low-cis low-c fis e ees gis f d)))))))
+
+(define (generate-clarinet-family-entry clarinet-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column clarinet-name clarinet-change-points)))
+ `(,clarinet-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . covered)))
+ (h
+ . ((offset . (0.0 . 6.25))
+ (stencil . ,(variable-column-circle-stencil 0.4))
+ (text? . #f)
+ (complexity . covered)))))
+ (left-hand
+ . ,(append `((thumb
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,clarinet-lh-thumb-key-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (R
+ . ((offset . (1.0 . 1.0))
+ (stencil . ,clarinet-lh-R-key-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (a
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,clarinet-lh-a-key-stencil)
+ (text? . ("A" . #f))
+ (complexity . trill)))
+ (gis
+ . ((offset . (0.8 . 1.0))
+ (stencil . ,clarinet-lh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (ees
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,clarinet-lh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (cis
+ . ((offset . (-0.85 . 0.2))
+ (stencil . ,clarinet-lh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (f
+ . ((offset . (3.6 . 0.5))
+ (stencil . ,clarinet-lh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))
+ (e
+ . ((offset . (2.05 . -3.65))
+ (stencil . ,clarinet-lh-e-key-stencil)
+ (text? . ("E" . #f))
+ (complexity . trill)))
+ (fis
+ . ((offset . (2.25 . -4.15))
+ (stencil . ,clarinet-lh-fis-key-stencil)
+ (text? . ("F" . 1))
+ (complexity . trill))))
+ (assoc-get 'left-extra-key-names change-points)))
+ (right-hand
+ . ,(append `((one
+ . ((offset . (0.0 . 0.75))
+ (stencil . ,clarinet-rh-one-key-stencil)
+ (text? . "1")
+ (complexity . trill)))
+ (two
+ . ((offset . (0.0 . 0.25))
+ (stencil . ,clarinet-rh-two-key-stencil)
+ (text? . "2")
+ (complexity . trill)))
+ (three
+ . ((offset . (0.0 . -0.25))
+ (stencil . ,clarinet-rh-three-key-stencil)
+ (text? . "3")
+ (complexity . trill)))
+ (four
+ . ((offset . (0.0 . -0.75))
+ (stencil . ,clarinet-rh-four-key-stencil)
+ (text? . "4")
+ (complexity . trill)))
+ (b
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,clarinet-rh-b-key-stencil)
+ (text? . ("B" . #f))
+ (complexity . trill)))
+ (fis
+ . ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-fis-key-stencil)
+ (text? . ("F" . 1))
+ (complexity . trill)))
+ (e
+ . ((offset . (,(+ 1.5 CL-RH-HAIR)
+ . ,(* 3 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-e-key-stencil)
+ (text? . ("E" . #f))
+ (complexity . trill)))
+ (ees
+ . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (gis
+ . ((offset . (,(+ 1.5 CL-RH-HAIR)
+ . ,(* 1 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill))))
+ (assoc-get 'bottom-group-key-names change-points)))))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . ,(append (assoc-get 'right-thumb-group change-points)
+ `(,(simple-stencil-alist '(hidden . midline)
+ '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-H-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils
+ . ,(make-left-hand-key-addresses '(thumb R)))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (-2.5 . 6.5)))
+ ((stencils
+ . ((left-hand . a) (left-hand . gis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (0.0 . 7.5)))
+ ,(simple-stencil-alist '(left-hand . ees)
+ '(1.0 . 5.0))
+ ((stencils
+ . ,(make-left-hand-key-addresses '(cis f e fis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (0.0 . 3.9)))
+ ((stencils
+ . ,(make-right-hand-key-addresses
+ '(one two three four)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-1.25 . 3.75)))
+ ,(simple-stencil-alist '(right-hand . b)
+ '(-1.0 . 1.5))
+ ((stencils
+ . ,(assoc-get 'bottom-right-group-key-addresses
+ change-points))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-4.0 . -0.75))))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ,(append (assoc-get 'low-rich-draw-rules change-points)
+ `((,apply-group-draw-rule-series
+ ,(append (assoc-get 'low-key-group change-points)
+ `(((left-hand . a) (left-hand . gis))
+ ,(make-right-hand-key-addresses
+ '(one two three four))
+ ,(assoc-get 'low-left-hand-key-addresses
+ change-points)
+ ,(assoc-get 'right-hand-key-addresses
+ change-points))))
+ (,rich-group-draw-rule
+ ((left-hand . R))
+ ((left-hand . thumb)))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline))))))
+ (extra-offset-instructions
+ . ,(append (assoc-get 'low-extra-offset-rule change-points)
+ `((,rich-group-extra-offset-rule
+ ((central-column . h))
+ ((central-column . one)
+ (left-hand . a)
+ (left-hand . gis))
+ (0.0 . 0.8))
+ (,uniform-extra-offset-rule (0.0 . 0.0)))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils . ((left-hand . thumb) (left-hand . R)))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (-2.5 . 6.5)))
+ ((stencils
+ . ,(assoc-get 'all-left-hand-key-addresses change-points))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 3.75)))
+ ((stencils
+ . ,(make-right-hand-key-addresses '(one two three four)))
+ (textual? . ,number-column-stencil)
+ (offset . (-1.25 . 3.75)))
+ ((stencils . ,(assoc-get 'right-hand-key-addresses
+ change-points))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(assoc-get 'all-left-hand-key-addresses change-points)
+ ,(make-right-hand-key-addresses '(one two three four))
+ ,(assoc-get 'right-hand-key-addresses change-points)))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,rich-group-extra-offset-rule
+ ((central-column . h))
+ ((central-column . one) (left-hand . a) (left-hand . gis))
+ (0.0 . 0.8))
+ (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;; Saxophone assembly instructions
+
+(define (saxophone-name-passerelle name)
+ (cond ((eqv? name 'saxophone) 'saxophone)
+ ((eqv? name 'soprano-saxophone) 'saxophone)
+ ((eqv? name 'alto-saxophone) 'saxophone)
+ ((eqv? name 'tenor-saxophone) 'saxophone)
+ ((eqv? name 'baritone-saxophone) 'baritone-saxophone)))
+
+(define saxophone-change-points
+ ((make-named-spreadsheet '(saxophone baritone-saxophone))
+ `((low-a-key-definition
+ . (()
+ ((low-a
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-low-a-key-stencil)
+ (text? . #f)
+ (complexity . trill))))))
+ (low-a-key-group
+ . (()
+ (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0)))))
+ (low-a-presence
+ . (()
+ ((left-hand . low-a))))
+ (left-hand-key-names
+ . (,(make-right-hand-key-addresses
+ '(ees d f front-f bes gis cis b low-bes))
+ ,(make-right-hand-key-addresses
+ '(ees d f front-f bes gis cis b low-bes low-a)))))))
+
+(define (generate-saxophone-family-entry saxophone-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column
+ (saxophone-name-passerelle saxophone-name) saxophone-change-points)))
+ `(,saxophone-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,column-circle-stencil)
+ (text? . #f)
+ (complexity . trill)))))
+ (left-hand
+ . ,(append (assoc-get 'low-a-key-definition change-points)
+ `((T
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-T-key-stencil)
+ (text? . ("T" . #f))
+ (complexity . trill)))
+ (ees
+ . ((offset . (0.4 . 1.6))
+ (stencil . ,saxophone-lh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (d
+ . ((offset . (1.5 . 0.5))
+ (stencil . ,saxophone-lh-d-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill)))
+ (f
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))
+ (front-f
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-front-f-key-stencil)
+ (text? . ("f" . #f))
+ (complexity . trill)))
+ (bes
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (gis
+ . ((offset . (0.0 . 1.1))
+ (stencil . ,saxophone-lh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (cis
+ . ((offset . (2.4 . 0.0))
+ (stencil . ,saxophone-lh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (b
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-lh-b-key-stencil)
+ (text? . ("B" . #f))
+ (complexity . trill)))
+ (low-bes
+ . ((offset . (0.0 . -0.2))
+ (stencil . ,saxophone-lh-low-bes-key-stencil)
+ (text? . ("b" . 0))
+ (complexity . trill))))))
+ (right-hand
+ . ((e
+ . ((offset . (0.0 . 2.0))
+ (stencil . ,saxophone-rh-e-key-stencil)
+ (text? . ("E" . #f))
+ (complexity . trill)))
+ (c
+ . ((offset . (0.0 . 0.9))
+ (stencil . ,saxophone-rh-c-key-stencil)
+ (text? . ("C" . #f))
+ (complexity . trill)))
+ (bes
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-rh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (high-fis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-rh-high-fis-key-stencil)
+ (text? . ("hF" . 1))
+ (complexity . trill)))
+ (fis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,saxophone-rh-fis-key-stencil)
+ (text? . ("F" . 1))
+ (complexity . trill)))
+ (ees
+ . ((offset . (0.0 . 0.7))
+ (stencil . ,saxophone-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (low-c
+ . ((offset . (-1.2 . -0.1))
+ (stencil . ,saxophone-rh-low-c-key-stencil)
+ (text? . ("c" . #f))
+ (complexity . trill)))))))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . ,(append (assoc-get 'low-a-key-group change-points)
+ `(,(simple-stencil-alist '(hidden . midline)
+ '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils
+ . ,(make-left-hand-key-addresses '(ees d f)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (1.5 . 6.8)))
+ ,(simple-stencil-alist '(left-hand . front-f)
+ '(0.0 . 7.35))
+ ,(simple-stencil-alist '(left-hand . T)
+ '(-2.2 . 6.5))
+ ,(simple-stencil-alist '(left-hand . bes)
+ '(0.0 . 6.2))
+ ((stencils
+ . ,(make-left-hand-key-addresses
+ '(gis cis b low-bes)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (1.2 . 3.5)))
+ ((stencils
+ . ,(make-right-hand-key-addresses '(e c bes)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-2.3 . 3.4)))
+ ,(simple-stencil-alist '(right-hand . high-fis)
+ '(-1.8 . 2.5))
+ ,(simple-stencil-alist '(right-hand . fis)
+ '(-1.5 . 1.5))
+ ((stencils
+ . ,(make-right-hand-key-addresses '(ees low-c)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-2.0 . 0.3))))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses '(ees d f))
+ ,(make-left-hand-key-addresses '(gis cis b low-bes))
+ ,(make-right-hand-key-addresses '(e c bes))
+ ,(make-right-hand-key-addresses '(ees low-c))))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,rich-group-extra-offset-rule
+ ((left-hand . bes))
+ ,(append (assoc-get 'low-a-presence change-points)
+ '((central-column . one)
+ (left-hand . front-f)
+ (left-hand . T)
+ (left-hand . ees)
+ (left-hand . d)
+ (left-hand . f)))
+ (0.0 . 1.0))
+ (,uniform-extra-offset-rule (0.0 . 0.0))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0))
+ ((stencils
+ . ,(assoc-get 'left-hand-key-names change-points))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 3.75)))
+ ((stencils
+ . ,(make-right-hand-key-addresses
+ '(e c bes high-fis fis ees low-c)))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses
+ '(ees d f front-f bes gis cis b low-bes))
+ ,(make-right-hand-key-addresses
+ '(e c bes high-fis fis ees low-c))))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;; Bassoon assembly instructions
+
+(define bassoon-change-points
+ ((make-named-spreadsheet '(bassoon contrabassoon))
+ `((left-hand-additional-keys .
+ (((a .
+ ((offset . (0.0 . -0.3))
+ (stencil . ,bassoon-lh-a-flick-key-stencil)
+ (text? . ("A" . #f))
+ (complexity . trill)))
+ (w .
+ ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-whisper-key-stencil)
+ (text? . ("w" . #f))
+ (complexity . trill))))
+ ()))
+ (right-hand-additional-keys .
+ (((cis .
+ ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-rh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (thumb-gis .
+ ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-rh-thumb-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill))))
+ ()))
+ (left-hand-flick-group .
+ (((left-hand . d) (left-hand . c) (left-hand . a))
+ ((left-hand . d) (left-hand . c))))
+ (left-hand-thumb-group .
+ (((left-hand . w) (left-hand . thumb-cis))
+ ((left-hand . thumb-cis))))
+ (cis-offset-instruction .
+ (((,rich-group-extra-offset-rule
+ ((right-hand . cis))
+ ,(append
+ '((hidden . midline) (hidden . long-midline))
+ (make-central-column-hole-addresses '(three two one))
+ (make-left-hand-key-addresses
+ '(low-b low-bes low-c low-d d a c w thumb-cis
+ high-ees high-e cis ees)))
+ (0.0 . 0.9)))
+ ()))
+ (right-hand-lower-thumb-group .
+ (((right-hand . thumb-gis) (right-hand . thumb-fis))
+ ((right-hand . thumb-fis))))
+ (right-hand-cis-key .
+ ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22)))
+ ()))
+ (back-left-hand-key-addresses .
+ ((low-b low-bes low-c low-d d a c w thumb-cis)
+ (low-b low-bes low-c low-d d c thumb-cis)))
+ (front-right-hand-key-addresses .
+ ((cis bes fis f gis) (bes fis f gis)))
+ (back-right-hand-key-addresses .
+ ((thumb-bes thumb-gis thumb-e thumb-fis)
+ (thumb-bes thumb-e thumb-fis))))))
+
+(define (generate-bassoon-family-entry bassoon-name)
+ (let*
+ ((change-points
+ (get-named-spreadsheet-column bassoon-name bassoon-change-points)))
+ `(,bassoon-name
+ . ((keys
+ . ((hidden
+ . ((midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,midline-stencil)
+ (text? . #f)
+ (complexity . basic)))
+ (long-midline
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,long-midline-stencil)
+ (text? . #f)
+ (complexity . basic)))))
+ (central-column
+ . ((one
+ . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,bassoon-cc-one-key-stencil)
+ (text? . #f)
+ (complexity . trill)))
+ (two
+ . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (three
+ . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (four
+ . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (five
+ . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))
+ (six
+ . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS))
+ (stencil . ,ring-column-circle-stencil)
+ (text? . #f)
+ (complexity . ring)))))
+ (left-hand
+ . ,(append (assoc-get 'left-hand-additional-keys
+ change-points)
+ `((high-e
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-he-key-stencil)
+ (text? . ("hE" . #f))
+ (complexity . trill)))
+ (high-ees
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-hees-key-stencil)
+ (text? . ("hE" . 0))
+ (complexity . trill)))
+ (ees
+ . ((offset . (-1.0 . 1.0))
+ (stencil . ,bassoon-lh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill)))
+ (cis
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill)))
+ (low-bes
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-lbes-key-stencil)
+ (text? . ("b" . 0))
+ (complexity . trill)))
+ (low-b
+ . ((offset . (-1.0 . -0.7))
+ (stencil . ,bassoon-lh-lb-key-stencil)
+ (text? . ("b" . #f))
+ (complexity . trill)))
+ (low-c
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-lc-key-stencil)
+ (text? . ("c" . #f))
+ (complexity . trill)))
+ (low-d
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-lh-ld-key-stencil)
+ (text? . ("d" . #f))
+ (complexity . trill)))
+ (d
+ . ((offset . (-1.5 . 2.0))
+ (stencil . ,bassoon-lh-d-flick-key-stencil)
+ (text? . ("D" . #f))
+ (complexity . trill)))
+ (c
+ . ((offset . (-0.8 . 1.1))
+ (stencil . ,bassoon-lh-c-flick-key-stencil)
+ (text? . ("C" . #f))
+ (complexity . trill)))
+ (thumb-cis
+ . ((offset . (2.0 . -1.0))
+ (stencil . ,bassoon-lh-thumb-cis-key-stencil)
+ (text? . ("C" . 1))
+ (complexity . trill))))))
+ (right-hand
+ . ,(append (assoc-get 'right-hand-additional-keys
+ change-points)
+ `((bes
+ . ((offset . (0.0 . 0.8))
+ (stencil . ,bassoon-rh-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (f
+ . ((offset . (-2.2 . 4.35))
+ (stencil . ,bassoon-rh-f-key-stencil)
+ (text? . ("F" . #f))
+ (complexity . trill)))
+ (fis
+ . ((offset . (1.5 . 1.0))
+ (stencil . ,bassoon-rh-fis-key-stencil)
+ (text? . ("F" . 1))
+ (complexity . trill)))
+ (gis
+ . ((offset . (0.0 . -0.15))
+ (stencil . ,bassoon-rh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (thumb-bes
+ . ((offset . (0.0 . 0.0))
+ (stencil . ,bassoon-rh-thumb-bes-key-stencil)
+ (text? . ("B" . 0))
+ (complexity . trill)))
+ (thumb-e
+ . ((offset . (1.75 . 0.4))
+ (stencil . ,bassoon-rh-thumb-e-key-stencil)
+ (text? . ("E" . #f))
+ (complexity . trill)))
+ (thumb-fis
+ . ((offset . (-1.0 . 1.6))
+ (stencil . ,bassoon-rh-thumb-fis-key-stencil)
+ (text? . ("F" . 1))
+ (complexity . trill))))))))
+ (graphical-commands
+ . ((stencil-alist
+ . ((stencils
+ . ,(append (assoc-get 'right-hand-cis-key change-points)
+ `(,(simple-stencil-alist '(hidden . midline)
+ '(0.0 . 3.75))
+ ,(simple-stencil-alist '(hidden . long-midline)
+ '(0.0 . 3.80))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ,(simple-stencil-alist '(left-hand . high-e)
+ '(-1.0 . 7.0))
+ ,(simple-stencil-alist '(left-hand . high-ees)
+ '(-1.0 . 6.0))
+ ((stencils
+ . ((left-hand . ees) (left-hand . cis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (3.0 . 3.75)))
+ ((stencils
+ . (((stencils
+ . ((left-hand . low-b)
+ (left-hand . low-bes)))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-2.0 . 9.0)))
+ ((stencils
+ . ,(assoc-get 'left-hand-flick-group
+ change-points))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (3.0 . 7.0)))
+ ,(simple-stencil-alist '(left-hand . low-c)
+ '(-1.0 . 4.5))
+ ,(simple-stencil-alist '(left-hand . low-d)
+ '(-1.0 . 0.1))
+ ((stencils
+ . ,(assoc-get 'left-hand-thumb-group
+ change-points))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (1.5 . -0.6)))))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-5.5 . 4.7)))
+ ,(simple-stencil-alist '(right-hand . bes)
+ '(1.0 . 1.2))
+ ((stencils
+ . ,(make-right-hand-key-addresses '(gis f fis)))
+ (xy-scale-function . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (2.0 . -1.25)))
+ ((stencils
+ . (((stencils
+ . ((right-hand . thumb-bes)
+ (right-hand . thumb-e)))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-1.22 . 5.25)))
+ ((stencils
+ . ,(assoc-get 'right-hand-lower-thumb-group
+ change-points))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))))
+ (xy-scale-function
+ . (,return-1 . ,return-1))
+ (textual? . #f)
+ (offset . (-5.0 . 0.0))))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses '(ees cis))
+ ,(make-left-hand-key-addresses
+ (assoc-get 'back-left-hand-key-addresses change-points))
+ ,(make-right-hand-key-addresses '(f fis gis))
+ ,(make-right-hand-key-addresses
+ (assoc-get 'back-right-hand-key-addresses change-points))))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (,bassoon-midline-rule
+ ,(append
+ (make-left-hand-key-addresses
+ (assoc-get 'back-left-hand-key-addresses change-points))
+ (make-right-hand-key-addresses
+ (assoc-get 'back-right-hand-key-addresses
+ change-points))))))
+ (extra-offset-instructions
+ . ,(append
+ (assoc-get 'cis-offset-instruction change-points)
+ `((,uniform-extra-offset-rule (0.0 . 0.0)))))))
+ (text-commands
+ . ((stencil-alist
+ . ((stencils
+ . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75))
+ ((stencils
+ . ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0)))
+ ((stencils
+ . ,(make-left-hand-key-addresses
+ '(high-e high-ees ees cis)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 3.75)))
+ ((stencils
+ . ,(make-left-hand-key-addresses
+ (assoc-get 'back-left-hand-key-addresses
+ change-points)))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 3.75)))
+ ((stencils
+ . ,(make-right-hand-key-addresses
+ (assoc-get 'front-right-hand-key-addresses
+ change-points)))
+ (textual? . ,lh-woodwind-text-stencil)
+ (offset . (1.5 . 0.0)))
+ ((stencils .
+ ,(make-right-hand-key-addresses
+ (assoc-get 'back-right-hand-key-addresses
+ change-points)))
+ (textual? . ,rh-woodwind-text-stencil)
+ (offset . (-1.25 . 0.0)))))
+ (xy-scale-function . (,identity . ,identity))
+ (textual? . #f)
+ (offset . (0.0 . 0.0))))
+ (draw-instructions
+ . ((,apply-group-draw-rule-series
+ (,(make-left-hand-key-addresses
+ (assoc-get 'back-left-hand-key-addresses change-points))
+ ,(make-right-hand-key-addresses
+ (assoc-get 'front-right-hand-key-addresses change-points))
+ ,(make-right-hand-key-addresses
+ (assoc-get 'back-right-hand-key-addresses change-points))
+ ,(make-left-hand-key-addresses '(high-e high-ees ees cis))))
+ (,group-automate-rule
+ ,(make-central-column-hole-addresses
+ CENTRAL-COLUMN-HOLE-LIST))
+ (,group-automate-rule ((hidden . midline)))))
+ (extra-offset-instructions
+ . ((,uniform-extra-offset-rule (0.0 . 0.0))))))))))
+
+;; Assembly functions
+
+; Scans a bank for name.
+; for example, '(left-hand . bes) will return bes in the left-hand
+; of a given bank
+(define (get-key name bank)
+ (assoc-get (cdr name) (assoc-get (car name) bank)))
+
+(define (translate-key-instruction key-instruction)
+ (let*
+ ((key-name (car key-instruction))
+ (key-complexity (assoc-get 'complexity (cdr key-instruction))))
+ (cond
+ ((eqv? key-complexity 'basic)
+ `((,key-name . ,(assoc-get 'F HOLE-FILL-LIST))))
+ ((eqv? key-complexity 'trill)
+ (make-symbol-alist key-name #t #f))
+ ((eqv? key-complexity 'covered)
+ (make-symbol-alist key-name #f #f))
+ ((eqv? key-complexity 'ring)
+ (make-symbol-alist key-name #f #t)))))
+
+(define (update-possb-list input-key possibility-list canonic-list)
+ (if (null? possibility-list)
+ (ly:error "woodwind markup error - invalid key or hole requested")
+ (if
+ (assoc-get input-key (cdar possibility-list))
+ (append
+ `(((,(caaar possibility-list) .
+ ,(assoc-get input-key (cdar possibility-list))) .
+ ,(assoc-get (caar possibility-list) canonic-list)))
+ (assoc-remove (caar possibility-list) canonic-list))
+ (update-possb-list input-key (cdr possibility-list) canonic-list))))
+
+(define (key-crawler input-list possibility-list)
+ (if (null? input-list)
+ (map car possibility-list)
+ (key-crawler
+ (cdr input-list)
+ (update-possb-list
+ (car input-list)
+ possibility-list
+ possibility-list))))
+
+(define (translate-draw-instructions input-alist key-name-alist)
+ (apply append
+ (map (lambda (short long)
+ (let*
+ ((key-instructions
+ (map (lambda (instr)
+ `(((,long . ,(car instr)) . 0)
+ . ,(translate-key-instruction instr)))
+ (assoc-get long key-name-alist))))
+ (key-crawler (assoc-get short input-alist) key-instructions)))
+ '(hd cc lh rh)
+ '(hidden central-column left-hand right-hand))))
+
+(define (uniform-draw-instructions key-name-alist)
+ (apply append
+ (map (lambda (long)
+ (map (lambda (key-instructions)
+ `((,long . ,(car key-instructions)) . 1))
+ (assoc-get long key-name-alist)))
+ '(hidden central-column left-hand right-hand))))
+
+(define (list-all-possible-keys key-name-alist)
+ (map (lambda (short long)
+ `(,short
+ . ,(map (lambda (key-instructions)
+ (car key-instructions))
+ (assoc-get long key-name-alist))))
+ '(cc lh rh)
+ '(central-column left-hand right-hand)))
+
+(define (list-all-possible-keys-verbose key-name-alist)
+ (map (lambda (short long)
+ `(,short
+ . ,(map (lambda (key-instructions)
+ `(,(car key-instructions)
+ . ,(map (lambda (x)
+ (car x))
+ (translate-key-instruction key-instructions))))
+ (assoc-get long key-name-alist))))
+ '(cc lh rh)
+ '(central-column left-hand right-hand)))
+
+(define woodwind-data-assembly-instructions
+ `((,generate-flute-family-entry . piccolo)
+ (,generate-flute-family-entry . flute)
+ (,generate-flute-family-entry . flute-b-extension)
+ (,generate-tin-whistle-family-entry . tin-whistle)
+ (,generate-oboe-family-entry . oboe)
+ (,generate-clarinet-family-entry . clarinet)
+ (,generate-clarinet-family-entry . bass-clarinet)
+ (,generate-clarinet-family-entry . low-bass-clarinet)
+ (,generate-saxophone-family-entry . saxophone)
+ (,generate-saxophone-family-entry . soprano-saxophone)
+ (,generate-saxophone-family-entry . alto-saxophone)
+ (,generate-saxophone-family-entry . tenor-saxophone)
+ (,generate-saxophone-family-entry . baritone-saxophone)
+ (,generate-bassoon-family-entry . bassoon)
+ (,generate-bassoon-family-entry . contrabassoon)))
+
+(define-public woodwind-instrument-list
+ (map cdr woodwind-data-assembly-instructions))
+
+(define woodwind-data-alist
+ (map (lambda (instruction)
+ ((car instruction) (cdr instruction)))
+ woodwind-data-assembly-instructions))
+
+;;; The brains of the markup function: takes drawing and offset information
+;;; about a key region and calls the appropriate stencils to draw the region.
+
+(define
+ (assemble-stencils
+ stencil-alist
+ key-bank
+ draw-instructions
+ extra-offset-instructions
+ radius
+ thick
+ xy-stretch
+ layout
+ props)
+ (apply
+ ly:stencil-add
+ (map (lambda (node)
+ (ly:stencil-translate
+ (if (pair? (cdr node))
+ (if (assoc-get 'textual? node)
+ ((assoc-get 'textual? node) (map (lambda (key)
+ (assoc-get 'text? key))
+ (map (lambda (instr)
+ (get-key
+ instr
+ key-bank))
+ (assoc-get 'stencils node)))
+ radius
+ (map (lambda (key)
+ (assoc-get
+ key
+ draw-instructions))
+ (assoc-get 'stencils
+ node))
+ layout
+ props)
+ (assemble-stencils
+ node
+ key-bank
+ draw-instructions
+ extra-offset-instructions
+ radius
+ thick
+ (coord-apply (assoc-get 'xy-scale-function stencil-alist)
+ xy-stretch)
+ layout
+ props))
+ (if (= 0 (assoc-get node draw-instructions))
+ empty-stencil
+ ((assoc-get 'stencil (get-key node key-bank))
+ radius
+ thick
+ (assoc-get node draw-instructions)
+ layout
+ props)))
+ (coord-scale
+ (coord-translate
+ (coord-scale
+ (assoc-get
+ 'offset
+ (if (pair? (cdr node))
+ node
+ (get-key node key-bank)))
+ (coord-apply
+ (assoc-get 'xy-scale-function stencil-alist)
+ xy-stretch))
+ (if
+ (assoc-get node extra-offset-instructions)
+ (assoc-get node extra-offset-instructions)
+ '(0.0 . 0.0)))
+ radius)))
+ (assoc-get 'stencils stencil-alist))))
+
+(define-public (print-keys instrument)
+ (let*
+ ((chosen-instrument
+ (begin
+ (format #t "\nPrinting keys for: ~a\n" instrument)
+ (assoc-get instrument woodwind-data-alist)))
+ (key-list (list-all-possible-keys (assoc-get 'keys chosen-instrument))))
+ (define (key-list-loop key-list)
+ (if (null? key-list)
+ 0
+ (begin
+ (format #t "~a\n ~a\n" (caar key-list) (cdar key-list))
+ (key-list-loop (cdr key-list)))))
+ (key-list-loop key-list)))
+
+(define-public (get-woodwind-key-list instrument)
+ (list-all-possible-keys-verbose
+ (assoc-get
+ 'keys
+ (assoc-get instrument woodwind-data-alist))))
+
+(define-public (print-keys-verbose instrument)
+ (let*
+ ((chosen-instrument
+ (begin
+ (format #t "\nPrinting keys in verbose mode for: ~a\n" instrument)
+ (assoc-get instrument woodwind-data-alist)))
+ (key-list
+ (list-all-possible-keys-verbose (assoc-get 'keys chosen-instrument))))
+ (define (key-list-loop key-list)
+ (if (null? key-list)
+ 0
+ (begin
+ (format #t "~a\n" (caar key-list))
+ (map (lambda (x)
+ (format #t " possibilities for ~a:\n ~a\n" (car x) (cdr x)))
+ (cdar key-list))
+ (key-list-loop (cdr key-list)))))
+ (key-list-loop key-list)))
+
+(define-markup-command
+ (woodwind-diagram layout props instrument input-list)
+ (symbol? list?)
+ #:category instrument-specific-markup ; markup category
+ "Make a woodwind-instrument diagram. For example, say
+
+@example
+\\markup \\woodwind-diagram #'oboe #'(1.4 0.1 #t ((lh . (d ees)) (cc . (five3qT1q)) (rh . (gis))))
+@end example
+
+@noindent
+for an oboe with the left-hand d key, left-hand ees key,
+and right-hand gis key depressed while the five-hole of
+the central column effectuates a trill between 1/4 and 3/4 closed.
+
+The following instruments are supported:
+@itemize @minus
+
+@item
+piccolo
+
+@item
+flute
+
+@item
+oboe
+
+@item
+clarinet
+
+@item
+bass-clarinet
+
+@item
+saxophone
+
+@item
+bassoon
+
+@item
+contrabassoon
+
+@end itemize
+
+To see all of the callable keys for a given instrument,
+include the function @code{(print-keys 'instrument)}
+in your .ly file, where instrument is the instrument
+whose keys you want to print.
+
+Certain keys allow for special configurations. The entire gamut of
+configurations possible is as follows:
+
+@itemize @minus
+
+@item
+1q (1/4 covered)
+
+@item
+1h (1/2 covered)
+
+@item
+3q (3/4 covered)
+
+@item
+R (ring depressed)
+
+@item
+F (fully covered; the default if no state put)
+
+@end itemize
+
+Additionally, these configurations can be used in trills. So, for example,
+@code{three3qTR} effectuates a trill between 3/4 full and ring depressed
+on the three hole. As another example, @code{threeRT} effectuates a trill
+between R and open, whereas @code{threeTR} effectuates a trill between open
+and shut. To see all of the possibilities for all of the keys of a given
+instrument, invoke @code{(print-keys-verbose 'instrument)}.
+
+Lastly, substituting an empty list for the pressed-key alist will result in
+a diagram with all of the keys drawn but none filled. ie...
+
+@example
+\\markup \\woodwind-diagram #'oboe #'(1.4 0.1 #t ())
+@end example"
+ (let* ((radius (car input-list))
+ (thick (cadr input-list))
+ (display-graphic (caddr input-list))
+ (xy-stretch `(1.0 . 2.5))
+ (chosen-instrument (assoc-get instrument woodwind-data-alist))
+ (chosen-instrument
+ (if (not chosen-instrument)
+ (ly:error "~a is not a valid woodwind instrument."
+ instrument)
+ chosen-instrument))
+ (stencil-info
+ (assoc-get
+ (if display-graphic 'graphical-commands 'text-commands)
+ chosen-instrument))
+ (user-draw-commands (cadddr input-list))
+ (pressed-info
+ (if (null? user-draw-commands)
+ (uniform-draw-instructions (assoc-get 'keys chosen-instrument))
+ (translate-draw-instructions
+ (append '((hd . ())) user-draw-commands)
+ (assoc-get 'keys chosen-instrument))))
+ (draw-info
+ (function-chain
+ pressed-info
+ (assoc-get 'draw-instructions stencil-info)))
+ (extra-offset-info
+ (function-chain
+ pressed-info
+ (assoc-get 'extra-offset-instructions stencil-info))))
+ (assemble-stencils
+ (assoc-get 'stencil-alist stencil-info)
+ (assoc-get 'keys chosen-instrument)
+ draw-info
+ extra-offset-info
+ radius
+ thick
+ xy-stretch
+ layout
+ props)))
\ No newline at end of file
projects / lilypond.git / commitdiff