(ending-moments (cdr group-list) new-start base-moment)))))
(define (larger-setting test-beam sorted-alist)
- (if (null? sorted-alist)
- '()
- (let* ((first-key (caar sorted-alist))
- (first-moment (fraction->moment first-key)))
- (if (moment<=? test-beam first-moment)
- (car sorted-alist)
- (larger-setting test-beam (cdr sorted-alist))))))
+ (if (null? sorted-alist)
+ '()
+ (let* ((first-key (caar sorted-alist))
+ (first-moment (fraction->moment first-key)))
+ (if (moment<=? test-beam first-moment)
+ (car sorted-alist)
+ (larger-setting test-beam (cdr sorted-alist))))))
(define (beat-end? moment beat-structure)
(pair? (member moment beat-structure))) ;; member returns a list if found, not #t
(let* ((base-moment (get 'baseMoment (ly:make-moment 1 4)))
(measure-length (get 'measureLength (ly:make-moment 1 1)))
(time-signature-fraction
- (get 'timeSignatureFraction '(4 . 4)))
+ (get 'timeSignatureFraction '(4 . 4)))
(beat-structure (get 'beatStructure '(1 1 1 1)))
(beat-endings (ending-moments beat-structure 0 base-moment))
(exceptions (sort (assoc-get 'end
(beam-half-measure (get 'beamHalfMeasure #t))
(type (moment->fraction test-beam))
(non-grace (ly:make-moment
- (ly:moment-main-numerator measure-pos)
- (ly:moment-main-denominator measure-pos)))
+ (ly:moment-main-numerator measure-pos)
+ (ly:moment-main-denominator measure-pos)))
(pos (if (ly:moment<? non-grace ZERO-MOMENT)
(ly:moment-add measure-length non-grace)
non-grace))
(car default-rule)
'()))
(exception-grouping (if (null? type-grouping)
- default-grouping
- type-grouping))
+ default-grouping
+ type-grouping))
(grouping-moment (if (null? type-grouping)
(fraction->moment default-beat-length)
test-beam))
(exception-moments (ending-moments
- exception-grouping 0 grouping-moment)))
+ exception-grouping 0 grouping-moment)))
- (if (= dir START)
+ (if (= dir START)
;; Start rules -- #t if beam is allowed to start
(or beam-half-measure ;; Start anywhere, but option for mid-measure
(not (equal? (ly:moment-add pos pos) measure-length))
(if (null? exception-grouping)
(beat-end? pos beat-endings) ;; no exception, so check beat ending
(member pos exception-moments))))))) ;; check exception rule
-
(define-public (make-autochange-music parser music)
(define (generate-split-list change-moment event-list acc)
(if (null? event-list)
- acc
- (let* ((now-tun (caar event-list))
- (evs (map car (cdar event-list)))
- (now (car now-tun))
- (notes (filter (lambda (x)
- (ly:in-event-class? x 'note-event))
- evs))
- (pitch (if (pair? notes)
- (ly:event-property (car notes) 'pitch)
- #f)))
- ;; tail recursive.
- (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
- (generate-split-list #f
- (cdr event-list)
- (cons (cons
+ acc
+ (let* ((now-tun (caar event-list))
+ (evs (map car (cdar event-list)))
+ (now (car now-tun))
+ (notes (filter (lambda (x)
+ (ly:in-event-class? x 'note-event))
+ evs))
+ (pitch (if (pair? notes)
+ (ly:event-property (car notes) 'pitch)
+ #f)))
+ ;; tail recursive.
+ (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
+ (generate-split-list #f
+ (cdr event-list)
+ (cons (cons
+
+ (if change-moment
+ change-moment
+ now)
+ (sign (ly:pitch-steps pitch))) acc))
+ (generate-split-list
+ (if pitch #f now)
+ (cdr event-list) acc)))))
- (if change-moment
- change-moment
- now)
- (sign (ly:pitch-steps pitch))) acc))
- (generate-split-list
- (if pitch #f now)
- (cdr event-list) acc)))))
-
(let* ((m (make-music 'AutoChangeMusic))
- (m1 (make-non-relative-music (context-spec-music music 'Voice "one")))
- (context-list (recording-group-emulate music
- (ly:parser-lookup parser 'partCombineListener)))
- (evs (car context-list))
+ (m1 (make-non-relative-music (context-spec-music music 'Voice "one")))
+ (context-list (recording-group-emulate music
+ (ly:parser-lookup parser 'partCombineListener)))
+ (evs (car context-list))
(rev (reverse! (cdar context-list)))
- (split (reverse! (generate-split-list
- #f
- rev
- '())
- '())))
+ (split (reverse! (generate-split-list
+ #f
+ rev
+ '())
+ '())))
(set! (ly:music-property m 'element) music)
(set! (ly:music-property m 'split-list) split)
m))
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; backend helpers.
(use-modules (scm ps-to-png)
- (scm paper-system)
- (ice-9 optargs))
+ (scm paper-system)
+ (ice-9 optargs))
(define-public (ly:system command)
(ly:debug (_ "Invoking `~a'...") (string-join command))
(let ((status (apply ly:spawn command)))
(if (> status 0)
- (begin
- (ly:warning (_ "`~a' failed (~a)\n") command status)
- ;; hmmm. what's the best failure option?
- (throw 'ly-file-failed)))))
+ (begin
+ (ly:warning (_ "`~a' failed (~a)\n") command status)
+ ;; hmmm. what's the best failure option?
+ (throw 'ly-file-failed)))))
(define-public (sanitize-command-option str)
"Kill dubious shell quoting."
-
+
(string-append
"\""
(regexp-substitute/global #f "[^-_ 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
(define-public (search-executable names)
(define (helper path lst)
(if (null? (cdr lst))
- (car lst)
- (if (search-path path (car lst)) (car lst)
- (helper path (cdr lst)))))
+ (car lst)
+ (if (search-path path (car lst)) (car lst)
+ (helper path (cdr lst)))))
(let ((path (parse-path (getenv "PATH"))))
(helper path names)))
(define-public (search-gs)
-
+
;; must be sure that we don't catch stuff from old GUBs.
(search-executable '("gs")))
-
+
(define-public (postscript->pdf paper-width paper-height name)
(let* ((pdf-name (string-append
- (dir-basename name ".ps" ".eps")
- ".pdf"))
- (is-eps (string-match "\\.eps$" name))
- (*unspecified* (if #f #f))
- (cmd
- (remove (lambda (x) (eq? x *unspecified*))
- (list
- (search-gs)
- (if (ly:get-option 'verbose) *unspecified* "-q")
- (if (or (ly:get-option 'gs-load-fonts)
- (ly:get-option 'gs-load-lily-fonts)
- (eq? PLATFORM 'windows))
- "-dNOSAFER"
- "-dSAFER")
-
- (if is-eps
- "-dEPSCrop"
- (ly:format "-dDEVICEWIDTHPOINTS=~$" paper-width))
- (if is-eps
- *unspecified*
- (ly:format "-dDEVICEHEIGHTPOINTS=~$" paper-height))
- "-dCompatibilityLevel=1.4"
- "-dNOPAUSE"
- "-dBATCH"
- "-r1200"
- "-sDEVICE=pdfwrite"
- (string-append "-sOutputFile=" pdf-name)
- "-c.setpdfwrite"
- (string-append "-f" name)))))
+ (dir-basename name ".ps" ".eps")
+ ".pdf"))
+ (is-eps (string-match "\\.eps$" name))
+ (*unspecified* (if #f #f))
+ (cmd
+ (remove (lambda (x) (eq? x *unspecified*))
+ (list
+ (search-gs)
+ (if (ly:get-option 'verbose) *unspecified* "-q")
+ (if (or (ly:get-option 'gs-load-fonts)
+ (ly:get-option 'gs-load-lily-fonts)
+ (eq? PLATFORM 'windows))
+ "-dNOSAFER"
+ "-dSAFER")
+
+ (if is-eps
+ "-dEPSCrop"
+ (ly:format "-dDEVICEWIDTHPOINTS=~$" paper-width))
+ (if is-eps
+ *unspecified*
+ (ly:format "-dDEVICEHEIGHTPOINTS=~$" paper-height))
+ "-dCompatibilityLevel=1.4"
+ "-dNOPAUSE"
+ "-dBATCH"
+ "-r1200"
+ "-sDEVICE=pdfwrite"
+ (string-append "-sOutputFile=" pdf-name)
+ "-c.setpdfwrite"
+ (string-append "-f" name)))))
(ly:message (_ "Converting to `~a'...\n") pdf-name)
(ly:system cmd)))
(define-public (postscript->png resolution paper-width paper-height name)
(let* ((verbose (ly:get-option 'verbose))
- (rename-page-1 #f))
+ (rename-page-1 #f))
;; Do not try to guess the name of the png file,
;; GS produces PNG files like BASE-page%d.png.
(ly:message (_ "Converting to ~a...") "PNG")
(make-ps-images name
- #:resolution resolution
- #:page-width paper-width
- #:page-height paper-height
- #:rename-page-1 rename-page-1
- #:be-verbose verbose
- #:anti-alias-factor (ly:get-option 'anti-alias-factor)
- #:pixmap-format (ly:get-option 'pixmap-format))
+ #:resolution resolution
+ #:page-width paper-width
+ #:page-height paper-height
+ #:rename-page-1 rename-page-1
+ #:be-verbose verbose
+ #:anti-alias-factor (ly:get-option 'anti-alias-factor)
+ #:pixmap-format (ly:get-option 'pixmap-format))
(ly:progress "\n")))
(define-public (postprocess-output paper-book module filename formats)
(let* ((completed (completize-formats formats))
- (base (dir-basename filename ".ps" ".eps"))
- (intermediate (remove (lambda (x) (member x formats)) completed)))
+ (base (dir-basename filename ".ps" ".eps"))
+ (intermediate (remove (lambda (x) (member x formats)) completed)))
(for-each (lambda (f)
- ((eval (string->symbol (format #f "convert-to-~a" f))
- module) paper-book filename)) completed)
+ ((eval (string->symbol (format #f "convert-to-~a" f))
+ module) paper-book filename)) completed)
(if (ly:get-option 'delete-intermediate-files)
- (for-each (lambda (f)
- (if (file-exists? f) (delete-file f)))
- (map (lambda (x) (string-append base "." x)) intermediate)))))
+ (for-each (lambda (f)
+ (if (file-exists? f) (delete-file f)))
+ (map (lambda (x) (string-append base "." x)) intermediate)))))
(define-public (completize-formats formats)
(define new-fmts '())
(if (member "pdf" formats)
(set! formats (cons "ps" formats)))
(for-each (lambda (x)
- (if (member x formats) (set! new-fmts (cons x new-fmts))))
- '("ps" "pdf" "png"))
+ (if (member x formats) (set! new-fmts (cons x new-fmts))))
+ '("ps" "pdf" "png"))
(uniq-list (reverse new-fmts)))
(define (header-to-file file-name key value)
(if (not (equal? "-" file-name))
(set! file-name (string-append file-name "." key)))
(ly:message (_ "Writing header field `~a' to `~a'...")
- key
- (if (equal? "-" file-name) "<stdout>" file-name))
+ key
+ (if (equal? "-" file-name) "<stdout>" file-name))
(if (equal? file-name "-")
(display value)
(let ((port (open-file file-name "w")))
- (display value port)
- (close-port port)))
+ (display value port)
+ (close-port port)))
(ly:progress "\n")
"")
string-append
(module-map
(lambda (sym var)
- (let ((val (if (variable-bound? var) (variable-ref var) "")))
- (if (and (memq sym fields) (string? val))
- (header-to-file basename sym val))
- ""))
+ (let ((val (if (variable-bound? var) (variable-ref var) "")))
+ (if (and (memq sym fields) (string? val))
+ (header-to-file basename sym val))
+ ""))
scope)))
(apply string-append (map output-scope scopes)))
(let ((systems (ly:paper-book-systems book)))
;; skip booktitles.
(if (and (not (ly:get-option 'include-book-title-preview))
- (pair? systems)
- (ly:prob-property (car systems) 'is-book-title #f))
- (cdr systems)
- systems)))
+ (pair? systems)
+ (ly:prob-property (car systems) 'is-book-title #f))
+ (cdr systems)
+ systems)))
(define-public (relevant-dump-systems systems)
(let ((to-dump-systems '()))
(for-each
- (lambda (sys)
- (if (or (paper-system-title? sys)
- (not (pair? to-dump-systems))
- (paper-system-title? (car to-dump-systems)))
- (set! to-dump-systems (cons sys to-dump-systems))))
- systems)
+ (lambda (sys)
+ (if (or (paper-system-title? sys)
+ (not (pair? to-dump-systems))
+ (paper-system-title? (car to-dump-systems)))
+ (set! to-dump-systems (cons sys to-dump-systems))))
+ systems)
to-dump-systems))
(define missing-stencil-list '())
""))
(map (lambda (x)
- (if (not (module-defined? output-module x))
- (begin
- (module-define! output-module x
- (lambda* (#:optional y . z)
- (missing-stencil-expression x)))
- (set! missing-stencil-list (append (list x)
- missing-stencil-list)))))
+ (if (not (module-defined? output-module x))
+ (begin
+ (module-define! output-module x
+ (lambda* (#:optional y . z)
+ (missing-stencil-expression x)))
+ (set! missing-stencil-list (append (list x)
+ missing-stencil-list)))))
(ly:all-stencil-commands)))
(define-public (remove-stencil-warnings output-module)
(for-each
- (lambda (x)
- (module-remove! output-module x))
- missing-stencil-list))
+ (lambda (x)
+ (module-remove! output-module x))
+ missing-stencil-list))
(define (filter-out pred? lst)
(filter (lambda (x) (not (pred? x))) lst))
or @code{#f}."
(let ((match (regexp-exec (make-regexp "(.*)-([0-9]*)") font-name)))
(if (regexp-match? match)
- (cons (match:substring match 1) (match:substring match 2))
- (cons font-name-designsize #f))))
+ (cons (match:substring match 1) (match:substring match 2))
+ (cons font-name-designsize #f))))
;; Example of a pango-physical-font
;; ("Emmentaler-11" "/home/janneke/vc/lilypond/out/share/lilypond/current/fonts/otf/emmentaler-11.otf" 0)
(define (pango-font-name pango-font)
(let ((pf-fonts (ly:pango-font-physical-fonts pango-font)))
(if (pair? pf-fonts)
- (pango-pf-font-name (car pf-fonts))
- "")))
+ (pango-pf-font-name (car pf-fonts))
+ "")))
(define-public (define-fonts paper define-font define-pango-pf)
"Return a string of all fonts used in @var{paper}, invoking the functions
definition."
(let* ((font-list (ly:paper-fonts paper))
- (pango-fonts (filter ly:pango-font? font-list))
- (other-fonts (filter-out ly:pango-font? font-list))
- (other-font-names (map ly:font-name other-fonts))
- (pango-only-fonts
- (filter-out (lambda (x)
- (member (pango-font-name x) other-font-names))
- pango-fonts)))
-
- (define (font-load-command font)
- (let* ((font-name (ly:font-name font))
- (designsize (ly:font-design-size font))
- (magnification (* (ly:font-magnification font)))
- (ops (ly:output-def-lookup paper 'output-scale))
- (scaling (* ops magnification designsize)))
- (if (equal? font-name "unknown")
- (display (list font font-name)))
- (define-font font font-name scaling)))
-
- (define (pango-font-load-command pango-font)
- (let* ((pf-fonts (ly:pango-font-physical-fonts pango-font))
- (pango-pf (if (pair? pf-fonts) (car pf-fonts) '("" "" 0)))
- (font-name (pango-pf-font-name pango-pf))
- (scaling (ly:output-def-lookup paper 'output-scale)))
- (if (equal? font-name "unknown")
- (display (list pango-font font-name)))
- (define-pango-pf pango-pf font-name scaling)))
+ (pango-fonts (filter ly:pango-font? font-list))
+ (other-fonts (filter-out ly:pango-font? font-list))
+ (other-font-names (map ly:font-name other-fonts))
+ (pango-only-fonts
+ (filter-out (lambda (x)
+ (member (pango-font-name x) other-font-names))
+ pango-fonts)))
- (string-append
- (apply string-append (map font-load-command other-fonts))
- (apply string-append (map pango-font-load-command pango-only-fonts)))))
+ (define (font-load-command font)
+ (let* ((font-name (ly:font-name font))
+ (designsize (ly:font-design-size font))
+ (magnification (* (ly:font-magnification font)))
+ (ops (ly:output-def-lookup paper 'output-scale))
+ (scaling (* ops magnification designsize)))
+ (if (equal? font-name "unknown")
+ (display (list font font-name)))
+ (define-font font font-name scaling)))
+
+ (define (pango-font-load-command pango-font)
+ (let* ((pf-fonts (ly:pango-font-physical-fonts pango-font))
+ (pango-pf (if (pair? pf-fonts) (car pf-fonts) '("" "" 0)))
+ (font-name (pango-pf-font-name pango-pf))
+ (scaling (ly:output-def-lookup paper 'output-scale)))
+ (if (equal? font-name "unknown")
+ (display (list pango-font font-name)))
+ (define-pango-pf pango-pf font-name scaling)))
+
+ (string-append
+ (apply string-append (map font-load-command other-fonts))
+ (apply string-append (map pango-font-load-command pango-only-fonts)))))
(let ((blot-diameter (layout-blot-diameter grob))
(height (interval-length extent)))
- (cond ((< thickness blot-diameter) thickness)
- ((< height blot-diameter) height)
- (else blot-diameter)))
+ (cond ((< thickness blot-diameter) thickness)
+ ((< height blot-diameter) height)
+ (else blot-diameter)))
0)))
- blot))
+ blot))
(define (get-span-glyph bar-glyph)
"Get the corresponding span glyph from the @code{span-glyph-bar-alist}.
@var{bar-glyph} string."
(let ((span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph)))
- (if (string? span-glyph)
- (set! span-glyph (string-pad-right
+ (if (string? span-glyph)
+ (set! span-glyph (string-pad-right
span-glyph
(string-length bar-glyph)
replacement-char)))
- span-glyph))
+ span-glyph))
(define (get-staff-symbol grob)
"Return the staff symbol corresponding to Grob @var{grob}."
(let* ((layout (ly:grob-layout grob))
(blot-diameter (ly:output-def-lookup layout 'blot-diameter)))
- blot-diameter))
+ blot-diameter))
(define (staff-symbol-line-count staff)
"Get or compute the number of lines of staff @var{staff}."
(let ((line-count 0))
- (if (ly:grob? staff)
- (let ((line-pos (ly:grob-property staff 'line-positions '())))
+ (if (ly:grob? staff)
+ (let ((line-pos (ly:grob-property staff 'line-positions '())))
- (set! line-count (if (pair? line-pos)
- (length line-pos)
- (ly:grob-property staff 'line-count 0)))))
+ (set! line-count (if (pair? line-pos)
+ (length line-pos)
+ (ly:grob-property staff 'line-count 0)))))
- line-count))
+ line-count))
(define (staff-symbol-line-span grob)
(let ((line-pos (ly:grob-property grob 'line-positions '()))
(iv (cons 0.0 0.0)))
- (if (pair? line-pos)
- (begin
- (set! iv (cons (car line-pos) (car line-pos)))
- (map (lambda (x)
- (set! iv (cons (min (car iv) x)
- (max (cdr iv) x))))
- (cdr line-pos)))
+ (if (pair? line-pos)
+ (begin
+ (set! iv (cons (car line-pos) (car line-pos)))
+ (map (lambda (x)
+ (set! iv (cons (min (car iv) x)
+ (max (cdr iv) x))))
+ (cdr line-pos)))
- (let ((line-count (ly:grob-property grob 'line-count 0)))
+ (let ((line-count (ly:grob-property grob 'line-count 0)))
- (set! iv (cons (- 1 line-count)
- (- line-count 1)))))
- iv))
+ (set! iv (cons (- 1 line-count)
+ (- line-count 1)))))
+ iv))
(define (staff-symbol-line-positions grob)
"Get or compute the @code{'line-positions} list from @var{grob}."
(let ((line-pos (ly:grob-property grob 'line-positions '())))
- (if (not (pair? line-pos))
- (let* ((line-count (ly:grob-property grob 'line-count 0))
- (height (- line-count 1.0)))
+ (if (not (pair? line-pos))
+ (let* ((line-count (ly:grob-property grob 'line-count 0))
+ (height (- line-count 1.0)))
- (set! line-pos (map (lambda (x)
- (- height (* x 2)))
- (iota line-count)))))
- line-pos))
+ (set! line-pos (map (lambda (x)
+ (- height (* x 2)))
+ (iota line-count)))))
+ line-pos))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal helper functions
(let ((proc (assoc-get glyph bar-glyph-print-procedures))
(stencil empty-stencil))
- (if (procedure? proc)
- (set! stencil (proc grob extent))
- (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph))
- stencil))
+ (if (procedure? proc)
+ (set! stencil (proc grob extent))
+ (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph))
+ stencil))
(define (string->string-list str)
"Convert a string into a list of strings with length 1.
(if (and (string? str)
(not (zero? (string-length str))))
(map (lambda (s)
- (string s))
+ (string s))
(string->list str))
(list "")))
annotation char from string @var{str}."
(let ((pos (string-index str annotation-char)))
- (if pos
- (substring str 0 pos)
- str)))
+ (if pos
+ (substring str 0 pos)
+ str)))
(define (check-for-annotation str)
"Check whether the annotation char is present in string @var{str}."
(if (string? str)
(if (string-index str annotation-char)
(ly:warning
- (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.")
- str))))
+ (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.")
+ str))))
(define (check-for-replacement str)
"Check whether the replacement char is present in string @var{str}."
(if (string? str)
(if (string-index str replacement-char)
(ly:warning
- (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.")
- str))))
+ (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.")
+ str))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functions used by external routines
(last-pos (1- (length sorted-elts)))
(idx 0))
- (map (lambda (g)
- (ly:grob-set-property!
- g
- 'has-span-bar
- (cons (if (eq? idx last-pos)
- #f
- grob)
- (if (zero? idx)
- #f
- grob)))
- (set! idx (1+ idx)))
- sorted-elts)))
+ (map (lambda (g)
+ (ly:grob-set-property!
+ g
+ 'has-span-bar
+ (cons (if (eq? idx last-pos)
+ #f
+ grob)
+ (if (zero? idx)
+ #f
+ grob)))
+ (set! idx (1+ idx)))
+ sorted-elts)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Line break decisions.
(check-for-annotation span-glyph)
;; only the last argument may call for replacements
(for-each (lambda (s)
- (check-for-replacement s))
+ (check-for-replacement s))
(list bar-glyph eol-glyph bol-glyph))
;; the bar-glyph-alist has entries like
;; (bar-glyph . ( eol-glyph . bol-glyph))
(set! bar-glyph-alist
- (acons bar-glyph (cons eol-glyph bol-glyph) bar-glyph-alist))
+ (acons bar-glyph (cons eol-glyph bol-glyph) bar-glyph-alist))
;; the span-bar-glyph-alist has entries like
;; (bar-glyph . span-glyph)
(set! span-bar-glyph-alist
- (acons bar-glyph span-glyph span-bar-glyph-alist)))
+ (acons bar-glyph span-glyph span-bar-glyph-alist)))
(define-session bar-glyph-alist '())
(if (or (not (string? glyph))
(> (string-length glyph) 1))
(ly:warning
- (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.")
- glyph)
+ (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.")
+ glyph)
(set! bar-glyph-print-procedures
- (acons glyph proc bar-glyph-print-procedures))))
+ (acons glyph proc bar-glyph-print-procedures))))
(define-session bar-glyph-print-procedures `())
(blot (calc-blot thickness extent grob))
(extent (bar-line::widen-bar-extent-on-span grob extent)))
- (ly:round-filled-box (cons 0 thickness)
- extent
- blot)))
+ (ly:round-filled-box (cons 0 thickness)
+ extent
+ blot)))
(define (make-thick-bar-line grob extent)
"Draw a thick bar line."
(blot (calc-blot thickness extent grob))
(extent (bar-line::widen-bar-extent-on-span grob extent)))
- (ly:round-filled-box (cons 0 thickness)
- extent
- blot)))
+ (ly:round-filled-box (cons 0 thickness)
+ extent
+ blot)))
(define (make-tick-bar-line grob extent)
"Draw a tick bar line."
(height (interval-end extent))
(blot (calc-blot staff-line-thickness extent grob)))
- (ly:round-filled-box (cons 0 staff-line-thickness)
- (cons (- height half-staff) (+ height half-staff))
- blot)))
+ (ly:round-filled-box (cons 0 staff-line-thickness)
+ (cons (- height half-staff) (+ height half-staff))
+ blot)))
(define (make-colon-bar-line grob extent)
"Draw repeat dots."
(- 0.5 correction))))
(counting (interval-length (cons i e)))
(stil-list (map
- (lambda (x)
- (ly:stencil-translate-axis
- dot (+ x correction) Y))
- (iota counting i 1))))
+ (lambda (x)
+ (ly:stencil-translate-axis
+ dot (+ x correction) Y))
+ (iota counting i 1))))
- (define (add-stencils! stil l)
- (if (null? l)
- stil
- (if (null? (cdr l))
- (ly:stencil-add stil (car l))
- (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
+ (define (add-stencils! stil l)
+ (if (null? l)
+ stil
+ (if (null? (cdr l))
+ (ly:stencil-add stil (car l))
+ (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
- (add-stencils! empty-stencil stil-list)))
+ (add-stencils! empty-stencil stil-list)))
(define (make-dashed-bar-line grob extent)
"Draw a dashed bar line."
(dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
(line-count (staff-symbol-line-count staff-symbol)))
- (if (< (abs (+ line-thickness
- (* (1- line-count) staff-space)
- (- height)))
- 0.1)
- (let ((blot (layout-blot-diameter grob))
- (half-space (/ staff-space 2.0))
- (half-thick (/ line-thickness 2.0))
- (stencil empty-stencil))
-
- (map (lambda (i)
- (let ((top-y (min (* (+ i dash-size) half-space)
- (+ (* (1- line-count) half-space)
- half-thick)))
- (bot-y (max (* (- i dash-size) half-space)
- (- 0 (* (1- line-count) half-space)
- half-thick))))
-
- (set! stencil
- (ly:stencil-add
- stencil
- (ly:round-filled-box (cons 0 thickness)
- (cons bot-y top-y)
- blot)))))
- (iota line-count (1- line-count) (- 2)))
- stencil)
- (let* ((dashes (/ height staff-space))
- (total-dash-size (/ height dashes))
- (factor (/ (- dash-size thickness) staff-space))
- (stencil (ly:stencil-translate-axis
- (ly:make-stencil (list 'dashed-line
- thickness
- (* factor total-dash-size)
- (* (- 1 factor) total-dash-size)
- 0
- height
- (* factor total-dash-size 0.5))
- (cons (/ thickness -2) (/ thickness 2))
- (cons 0 height))
- (interval-start extent)
- Y)))
-
- (ly:stencil-translate-axis stencil (/ thickness 2) X)))))
+ (if (< (abs (+ line-thickness
+ (* (1- line-count) staff-space)
+ (- height)))
+ 0.1)
+ (let ((blot (layout-blot-diameter grob))
+ (half-space (/ staff-space 2.0))
+ (half-thick (/ line-thickness 2.0))
+ (stencil empty-stencil))
+
+ (map (lambda (i)
+ (let ((top-y (min (* (+ i dash-size) half-space)
+ (+ (* (1- line-count) half-space)
+ half-thick)))
+ (bot-y (max (* (- i dash-size) half-space)
+ (- 0 (* (1- line-count) half-space)
+ half-thick))))
+
+ (set! stencil
+ (ly:stencil-add
+ stencil
+ (ly:round-filled-box (cons 0 thickness)
+ (cons bot-y top-y)
+ blot)))))
+ (iota line-count (1- line-count) (- 2)))
+ stencil)
+ (let* ((dashes (/ height staff-space))
+ (total-dash-size (/ height dashes))
+ (factor (/ (- dash-size thickness) staff-space))
+ (stencil (ly:stencil-translate-axis
+ (ly:make-stencil (list 'dashed-line
+ thickness
+ (* factor total-dash-size)
+ (* (- 1 factor) total-dash-size)
+ 0
+ height
+ (* factor total-dash-size 0.5))
+ (cons (/ thickness -2) (/ thickness 2))
+ (cons 0 height))
+ (interval-start extent)
+ Y)))
+
+ (ly:stencil-translate-axis stencil (/ thickness 2) X)))))
(define ((make-segno-bar-line show-segno) grob extent)
(thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
(thin-stil (make-simple-bar-line grob extent))
(double-line-stil (ly:stencil-combine-at-edge
- thin-stil
- X
- LEFT
- thin-stil
- thinkern))
+ thin-stil
+ X
+ LEFT
+ thin-stil
+ thinkern))
(segno (ly:font-get-glyph (ly:grob-default-font grob)
"scripts.varsegno"))
(stencil (ly:stencil-add
- (if show-segno
- segno
- (ly:make-stencil
- ""
- (ly:stencil-extent segno X)
- (cons 0 0)))
- (ly:stencil-translate-axis
- double-line-stil
- (* 1/2 thinkern)
- X))))
-
- stencil))
+ (if show-segno
+ segno
+ (ly:make-stencil
+ ""
+ (ly:stencil-extent segno X)
+ (cons 0 0)))
+ (ly:stencil-translate-axis
+ double-line-stil
+ (* 1/2 thinkern)
+ X))))
+
+ stencil))
(define (make-kievan-bar-line grob extent)
"Draw a kievan bar line."
(let* ((font (ly:grob-default-font grob))
(stencil (stencil-whiteout
- (ly:font-get-glyph font "scripts.barline.kievan"))))
+ (ly:font-get-glyph font "scripts.barline.kievan"))))
- ;; the kievan bar line has no staff lines underneath,
- ;; so we whiteout them and move the grob to a higher layer
- (ly:grob-set-property! grob 'layer 1)
- stencil))
+ ;; the kievan bar line has no staff lines underneath,
+ ;; so we whiteout them and move the grob to a higher layer
+ (ly:grob-set-property! grob 'layer 1)
+ stencil))
(define ((make-bracket-bar-line dir) grob extent)
"Draw a bracket-style bar line. If @var{dir} is set to @code{LEFT}, the
(cons 0 0)
(ly:stencil-extent brackettips-up Y)))
(tip-down-stil (ly:make-stencil (ly:stencil-expr brackettips-down)
- (cons 0 0)
- (ly:stencil-extent brackettips-down Y)))
+ (cons 0 0)
+ (ly:stencil-extent brackettips-down Y)))
(stencil (ly:stencil-add
- thick-stil
- (ly:stencil-translate-axis tip-up-stil
- (interval-end extent)
- Y)
- (ly:stencil-translate-axis tip-down-stil
- (interval-start extent)
- Y))))
-
- (if (eq? dir LEFT)
- stencil
- (ly:stencil-scale stencil -1 1))))
+ thick-stil
+ (ly:stencil-translate-axis tip-up-stil
+ (interval-end extent)
+ Y)
+ (ly:stencil-translate-axis tip-down-stil
+ (interval-start extent)
+ Y))))
+
+ (if (eq? dir LEFT)
+ stencil
+ (ly:stencil-scale stencil -1 1))))
(define ((make-spacer-bar-line glyph) grob extent)
"Draw an invisible bar line which has the same dimensions as the one
(let* ((stil (glyph->stencil glyph grob extent))
(stil-x-extent (ly:stencil-extent stil X)))
- (ly:make-stencil "" stil-x-extent extent)))
+ (ly:make-stencil "" stil-x-extent extent)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bar line callbacks
(let ((staff-symbol (get-staff-symbol grob))
(staff-extent (cons 0 0)))
- (if (ly:grob? staff-symbol)
- (let ((bar-line-color (ly:grob-property grob 'color))
- (staff-color (ly:grob-property staff-symbol 'color))
- (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))
- (staff-space (ly:staff-symbol-staff-space grob)))
-
- (set! staff-extent (ly:staff-symbol::height staff-symbol))
-
- (if (zero? staff-space)
- (set! staff-space 1.0))
-
- (if (< (interval-length staff-extent) staff-space)
- ;; staff is too small (perhaps consists of a single line);
- ;; extend the bar line to make it visible
- (set! staff-extent
- (interval-widen staff-extent staff-space))
- ;; Due to rounding problems, bar lines extending to the outermost edges
- ;; of the staff lines appear wrongly in on-screen display
- ;; (and, to a lesser extent, in print) - they stick out a pixel.
- ;; The solution is to extend bar lines only to the middle
- ;; of the staff line - unless they have different colors,
- ;; when it would be undesirable.
- ;;
- ;; This reduction should not influence whether the bar is to be
- ;; expanded later, so length is not updated on purpose.
- (if (eq? bar-line-color staff-color)
- (set! staff-extent
- (interval-widen staff-extent
- (- half-staff-line-thickness)))))))
- staff-extent))
+ (if (ly:grob? staff-symbol)
+ (let ((bar-line-color (ly:grob-property grob 'color))
+ (staff-color (ly:grob-property staff-symbol 'color))
+ (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))
+ (staff-space (ly:staff-symbol-staff-space grob)))
+
+ (set! staff-extent (ly:staff-symbol::height staff-symbol))
+
+ (if (zero? staff-space)
+ (set! staff-space 1.0))
+
+ (if (< (interval-length staff-extent) staff-space)
+ ;; staff is too small (perhaps consists of a single line);
+ ;; extend the bar line to make it visible
+ (set! staff-extent
+ (interval-widen staff-extent staff-space))
+ ;; Due to rounding problems, bar lines extending to the outermost edges
+ ;; of the staff lines appear wrongly in on-screen display
+ ;; (and, to a lesser extent, in print) - they stick out a pixel.
+ ;; The solution is to extend bar lines only to the middle
+ ;; of the staff line - unless they have different colors,
+ ;; when it would be undesirable.
+ ;;
+ ;; This reduction should not influence whether the bar is to be
+ ;; expanded later, so length is not updated on purpose.
+ (if (eq? bar-line-color staff-color)
+ (set! staff-extent
+ (interval-widen staff-extent
+ (- half-staff-line-thickness)))))))
+ staff-extent))
;; this function may come in handy when defining new bar line glyphs, so
;; we make it public.
(let ((staff-symbol (get-staff-symbol grob))
(has-span-bar (ly:grob-property grob 'has-span-bar #f)))
- (if (and (ly:grob? staff-symbol)
- (pair? has-span-bar))
- (let ((bar-line-color (ly:grob-property grob 'color))
- (staff-color (ly:grob-property staff-symbol 'color))
- (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)))
- (if (eq? bar-line-color staff-color)
- ;; if the colors are equal, ly:bar-line::calc-bar-extent has
- ;; shortened the bar line extent by a half-staff-line-thickness
- ;; this is reverted on the interval bounds where span bars appear:
- (begin
- (and (ly:grob? (car has-span-bar))
- (set! extent (cons (- (car extent) half-staff-line-thickness)
- (cdr extent))))
- (and (ly:grob? (cdr has-span-bar))
- (set! extent (cons (car extent)
- (+ (cdr extent) half-staff-line-thickness))))))))
- extent))
+ (if (and (ly:grob? staff-symbol)
+ (pair? has-span-bar))
+ (let ((bar-line-color (ly:grob-property grob 'color))
+ (staff-color (ly:grob-property staff-symbol 'color))
+ (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)))
+ (if (eq? bar-line-color staff-color)
+ ;; if the colors are equal, ly:bar-line::calc-bar-extent has
+ ;; shortened the bar line extent by a half-staff-line-thickness
+ ;; this is reverted on the interval bounds where span bars appear:
+ (begin
+ (and (ly:grob? (car has-span-bar))
+ (set! extent (cons (- (car extent) half-staff-line-thickness)
+ (cdr extent))))
+ (and (ly:grob? (cdr has-span-bar))
+ (set! extent (cons (car extent)
+ (+ (cdr extent) half-staff-line-thickness))))))))
+ extent))
(define (bar-line::bar-y-extent grob refpoint)
"Compute the y-extent of the bar line relative to @var{refpoint}."
(rel-y (ly:grob-relative-coordinate grob refpoint Y))
(y-extent (coord-translate extent rel-y)))
- y-extent))
+ y-extent))
(define-public (ly:bar-line::print grob)
"The print routine for bar lines."
(let ((glyph-name (ly:grob-property grob 'glyph-name))
(extent (ly:grob-property grob 'bar-extent '(0 . 0))))
- (if (and glyph-name
- (> (interval-length extent) 0))
- (bar-line::compound-bar-line grob glyph-name extent)
- #f)))
+ (if (and glyph-name
+ (> (interval-length extent) 0))
+ (bar-line::compound-bar-line grob glyph-name extent)
+ #f)))
(define-public (bar-line::compound-bar-line grob bar-glyph extent)
"Build the bar line stencil."
(let* ((line-thickness (layout-line-thickness grob))
(kern (* (ly:grob-property grob 'kern 1) line-thickness))
(bar-glyph-list (string->string-list
- (strip-string-annotation bar-glyph)))
+ (strip-string-annotation bar-glyph)))
(span-glyph (get-span-glyph bar-glyph))
(span-glyph-list (string->string-list span-glyph))
(neg-stencil empty-stencil)
(is-first-neg-stencil #t)
(is-first-stencil #t))
- ;; We build up two separate stencils first:
- ;; (1) the neg-stencil is built from all glyphs that have
- ;; a replacement-char in the span bar
- ;; (2) the main stencil is built from all remaining glyphs
- ;;
- ;; Afterwards the neg-stencil is attached left to the
- ;; stencil; this ensures that the main stencil starts
- ;; at x = 0.
- ;;
- ;; For both routines holds:
- ;; we stack the stencils obtained by the corresponding
- ;; single glyphs with spacing 'kern' except for the
- ;; first stencil
- ;; (Thanks to Harm who came up with this idea!)
- (for-each (lambda (bar span)
- (if (and (string=? span (string replacement-char))
- is-first-stencil)
- (begin
- (set! neg-stencil
- (ly:stencil-combine-at-edge
- neg-stencil
- X
- RIGHT
- (glyph->stencil bar grob extent)
- (if is-first-neg-stencil 0 kern)))
- (set! is-first-neg-stencil #f))
- (begin
- (set! stencil
- (ly:stencil-combine-at-edge
- stencil
- X
- RIGHT
- (glyph->stencil bar grob extent)
- (if is-first-stencil 0 kern)))
- (set! is-first-stencil #f))))
- bar-glyph-list span-glyph-list)
- ;; if we have a non-empty neg-stencil,
- ;; we attach it to the left side of the stencil
- (and (not is-first-neg-stencil)
- (set! stencil
- (ly:stencil-combine-at-edge
- stencil
- X
- LEFT
- neg-stencil
- kern)))
- stencil))
+ ;; We build up two separate stencils first:
+ ;; (1) the neg-stencil is built from all glyphs that have
+ ;; a replacement-char in the span bar
+ ;; (2) the main stencil is built from all remaining glyphs
+ ;;
+ ;; Afterwards the neg-stencil is attached left to the
+ ;; stencil; this ensures that the main stencil starts
+ ;; at x = 0.
+ ;;
+ ;; For both routines holds:
+ ;; we stack the stencils obtained by the corresponding
+ ;; single glyphs with spacing 'kern' except for the
+ ;; first stencil
+ ;; (Thanks to Harm who came up with this idea!)
+ (for-each (lambda (bar span)
+ (if (and (string=? span (string replacement-char))
+ is-first-stencil)
+ (begin
+ (set! neg-stencil
+ (ly:stencil-combine-at-edge
+ neg-stencil
+ X
+ RIGHT
+ (glyph->stencil bar grob extent)
+ (if is-first-neg-stencil 0 kern)))
+ (set! is-first-neg-stencil #f))
+ (begin
+ (set! stencil
+ (ly:stencil-combine-at-edge
+ stencil
+ X
+ RIGHT
+ (glyph->stencil bar grob extent)
+ (if is-first-stencil 0 kern)))
+ (set! is-first-stencil #f))))
+ bar-glyph-list span-glyph-list)
+ ;; if we have a non-empty neg-stencil,
+ ;; we attach it to the left side of the stencil
+ (and (not is-first-neg-stencil)
+ (set! stencil
+ (ly:stencil-combine-at-edge
+ stencil
+ X
+ LEFT
+ neg-stencil
+ kern)))
+ stencil))
(define-public (ly:bar-line::calc-anchor grob)
"Calculate the anchor position of a bar line. The anchor is used for
(x-extent (ly:grob-extent grob grob X))
(anchor 0.0))
- (and (> (interval-length x-extent) 0)
- (if (or (= (length bar-glyph-list) 1)
- (string=? bar-glyph span-glyph)
- (string=? span-glyph ""))
- ;; We use the x-extent of the stencil if either
- ;; - we have a single bar-glyph
- ;; - bar-glyph and span-glyph are identical
- ;; - we have no span-glyph
- (set! anchor (interval-center x-extent))
- ;; If the conditions above do not hold,the anchor is the
- ;; center of the corresponding span bar stencil extent
- (set! anchor (interval-center
- (ly:stencil-extent
- (span-bar::compound-bar-line grob bar-glyph dummy-extent)
- X)))))
- anchor))
+ (and (> (interval-length x-extent) 0)
+ (if (or (= (length bar-glyph-list) 1)
+ (string=? bar-glyph span-glyph)
+ (string=? span-glyph ""))
+ ;; We use the x-extent of the stencil if either
+ ;; - we have a single bar-glyph
+ ;; - bar-glyph and span-glyph are identical
+ ;; - we have no span-glyph
+ (set! anchor (interval-center x-extent))
+ ;; If the conditions above do not hold,the anchor is the
+ ;; center of the corresponding span bar stencil extent
+ (set! anchor (interval-center
+ (ly:stencil-extent
+ (span-bar::compound-bar-line grob bar-glyph dummy-extent)
+ X)))))
+ anchor))
(define-public (bar-line::calc-glyph-name grob)
"Determine the @code{glyph-name} of the bar line depending on the
glyph
(if (and result
(string? (index-cell result dir)))
- (index-cell result dir)
- #f))))
- glyph-name))
+ (index-cell result dir)
+ #f))))
+ glyph-name))
(define-public (bar-line::calc-break-visibility grob)
"Calculate the visibility of a bar line at line breaks."
(pos (1- (ly:grob-array-length elts)))
(glyph-name '()))
- (while (and (eq? glyph-name '())
- (> pos -1))
- (begin (set! glyph-name
- (ly:grob-property (ly:grob-array-ref elts pos)
- 'glyph-name))
- (set! pos (1- pos))))
- (if (eq? glyph-name '())
- (begin (ly:grob-suicide! grob)
- (set! glyph-name "")))
- glyph-name))
+ (while (and (eq? glyph-name '())
+ (> pos -1))
+ (begin (set! glyph-name
+ (ly:grob-property (ly:grob-array-ref elts pos)
+ 'glyph-name))
+ (set! pos (1- pos))))
+ (if (eq? glyph-name '())
+ (begin (ly:grob-suicide! grob)
+ (set! glyph-name "")))
+ glyph-name))
(define-public (ly:span-bar::width grob)
"Compute the width of the SpanBar stencil."
(let ((width (cons 0 0)))
- (if (grob::is-live? grob)
- (let* ((glyph-name (ly:grob-property grob 'glyph-name))
- (stencil (span-bar::compound-bar-line grob
- glyph-name
- dummy-extent)))
+ (if (grob::is-live? grob)
+ (let* ((glyph-name (ly:grob-property grob 'glyph-name))
+ (stencil (span-bar::compound-bar-line grob
+ glyph-name
+ dummy-extent)))
- (set! width (ly:stencil-extent stencil X))))
- width))
+ (set! width (ly:stencil-extent stencil X))))
+ width))
(define-public (ly:span-bar::before-line-breaking grob)
"A dummy callback that kills the Grob @var{grob} if it contains
no elements."
(let ((elts (ly:grob-object grob 'elements)))
- (if (zero? (ly:grob-array-length elts))
- (ly:grob-suicide! grob))))
+ (if (zero? (ly:grob-array-length elts))
+ (ly:grob-suicide! grob))))
(define-public (span-bar::compound-bar-line grob bar-glyph extent)
"Build the stencil of the span bar."
(let* ((line-thickness (layout-line-thickness grob))
(kern (* (ly:grob-property grob 'kern 1) line-thickness))
(bar-glyph-list (string->string-list
- (strip-string-annotation bar-glyph)))
+ (strip-string-annotation bar-glyph)))
(span-glyph (assoc-get bar-glyph span-bar-glyph-alist 'undefined))
(stencil empty-stencil))
- (if (string? span-glyph)
- (let ((span-glyph-list (string->string-list span-glyph))
- (is-first-stencil #t))
-
- (for-each (lambda (bar span)
- ;; the stencil stack routine is similar to the one
- ;; used in bar-line::compound-bar-line, but here,
- ;; leading replacement-chars are discarded.
- (if (not (and (string=? span (string replacement-char))
- is-first-stencil))
- (begin
- (set! stencil
- (ly:stencil-combine-at-edge
- stencil
- X
- RIGHT
- ;; if the current glyph is the replacement-char,
- ;; we take the corresponding glyph from the
- ;; bar-glyph-list and insert an empty stencil
- ;; with the appropriate width.
- ;; (this method would fail if the bar-glyph-list
- ;; were shorter than the span-glyph-list,
- ;; but this makes hardly any sense from a
- ;; typographical point of view
- (if (string=? span (string replacement-char))
- ((make-spacer-bar-line bar) grob extent)
- (glyph->stencil span grob extent))
- (if is-first-stencil 0 kern)))
- (set! is-first-stencil #f))))
- bar-glyph-list span-glyph-list))
- ;; if span-glyph is not a string, it may be #f or 'undefined;
- ;; the latter signals that the span bar for the current bar-glyph
- ;; is undefined, so we raise a warning.
- (if (eq? span-glyph 'undefined)
- (ly:warning
- (_ "No span bar glyph defined for bar glyph '~a'; ignoring.")
- bar-glyph)))
- stencil))
+ (if (string? span-glyph)
+ (let ((span-glyph-list (string->string-list span-glyph))
+ (is-first-stencil #t))
+
+ (for-each (lambda (bar span)
+ ;; the stencil stack routine is similar to the one
+ ;; used in bar-line::compound-bar-line, but here,
+ ;; leading replacement-chars are discarded.
+ (if (not (and (string=? span (string replacement-char))
+ is-first-stencil))
+ (begin
+ (set! stencil
+ (ly:stencil-combine-at-edge
+ stencil
+ X
+ RIGHT
+ ;; if the current glyph is the replacement-char,
+ ;; we take the corresponding glyph from the
+ ;; bar-glyph-list and insert an empty stencil
+ ;; with the appropriate width.
+ ;; (this method would fail if the bar-glyph-list
+ ;; were shorter than the span-glyph-list,
+ ;; but this makes hardly any sense from a
+ ;; typographical point of view
+ (if (string=? span (string replacement-char))
+ ((make-spacer-bar-line bar) grob extent)
+ (glyph->stencil span grob extent))
+ (if is-first-stencil 0 kern)))
+ (set! is-first-stencil #f))))
+ bar-glyph-list span-glyph-list))
+ ;; if span-glyph is not a string, it may be #f or 'undefined;
+ ;; the latter signals that the span bar for the current bar-glyph
+ ;; is undefined, so we raise a warning.
+ (if (eq? span-glyph 'undefined)
+ (ly:warning
+ (_ "No span bar glyph defined for bar glyph '~a'; ignoring.")
+ bar-glyph)))
+ stencil))
;; The method used in the following routine depends on bar_engraver
;; not being removed from staff context. If bar_engraver is removed,
(bar-glyph (ly:grob-property grob 'glyph-name))
(span-bar empty-stencil))
- (if (string? bar-glyph)
- (let ((extents '())
- (make-span-bars '())
- (model-bar #f))
-
- ;; we compute the extents of each system and store them
- ;; in a list; dito for the 'allow-span-bar property.
- ;; model-bar takes the bar grob, if given.
- (map (lambda (bar)
- (let ((ext (bar-line::bar-y-extent bar refp))
- (staff-symbol (ly:grob-object bar 'staff-symbol)))
-
- (if (ly:grob? staff-symbol)
- (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
-
- (set! ext (interval-union ext refp-extent))
-
- (if (> (interval-length ext) 0)
- (begin
- (set! extents (append extents (list ext)))
- (set! model-bar bar)
- (set! make-span-bars
- (append make-span-bars
- (list (ly:grob-property
- bar
- 'allow-span-bar
- #t))))))))))
- elts)
- ;; if there is no bar grob, we use the callback argument
- (if (not model-bar)
- (set! model-bar grob))
- ;; we discard the first entry in make-span-bars,
- ;; because its corresponding bar line is the
- ;; uppermost and therefore not connected to
- ;; another bar line
- (if (pair? make-span-bars)
- (set! make-span-bars (cdr make-span-bars)))
- ;; the span bar reaches from the lower end of the upper staff
- ;; to the upper end of the lower staff - when allow-span-bar is #t
- (reduce (lambda (curr prev)
- (let ((span-extent (cons 0 0))
- (allow-span-bar (car make-span-bars)))
-
- (set! make-span-bars (cdr make-span-bars))
- (if (> (interval-length prev) 0)
- (begin
- (set! span-extent (cons (cdr prev)
- (car curr)))
- ;; draw the span bar only when the staff lines
- ;; don't overlap and allow-span-bar is #t:
- (and (> (interval-length span-extent) 0)
- allow-span-bar
- (set! span-bar
- (ly:stencil-add
- span-bar
- (span-bar::compound-bar-line
- model-bar
- bar-glyph
- span-extent))))))
- curr))
- "" extents)
- (set! span-bar (ly:stencil-translate-axis
- span-bar
- (- (ly:grob-relative-coordinate grob refp Y))
- Y))))
- span-bar))
+ (if (string? bar-glyph)
+ (let ((extents '())
+ (make-span-bars '())
+ (model-bar #f))
+
+ ;; we compute the extents of each system and store them
+ ;; in a list; dito for the 'allow-span-bar property.
+ ;; model-bar takes the bar grob, if given.
+ (map (lambda (bar)
+ (let ((ext (bar-line::bar-y-extent bar refp))
+ (staff-symbol (ly:grob-object bar 'staff-symbol)))
+
+ (if (ly:grob? staff-symbol)
+ (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
+
+ (set! ext (interval-union ext refp-extent))
+
+ (if (> (interval-length ext) 0)
+ (begin
+ (set! extents (append extents (list ext)))
+ (set! model-bar bar)
+ (set! make-span-bars
+ (append make-span-bars
+ (list (ly:grob-property
+ bar
+ 'allow-span-bar
+ #t))))))))))
+ elts)
+ ;; if there is no bar grob, we use the callback argument
+ (if (not model-bar)
+ (set! model-bar grob))
+ ;; we discard the first entry in make-span-bars,
+ ;; because its corresponding bar line is the
+ ;; uppermost and therefore not connected to
+ ;; another bar line
+ (if (pair? make-span-bars)
+ (set! make-span-bars (cdr make-span-bars)))
+ ;; the span bar reaches from the lower end of the upper staff
+ ;; to the upper end of the lower staff - when allow-span-bar is #t
+ (reduce (lambda (curr prev)
+ (let ((span-extent (cons 0 0))
+ (allow-span-bar (car make-span-bars)))
+
+ (set! make-span-bars (cdr make-span-bars))
+ (if (> (interval-length prev) 0)
+ (begin
+ (set! span-extent (cons (cdr prev)
+ (car curr)))
+ ;; draw the span bar only when the staff lines
+ ;; don't overlap and allow-span-bar is #t:
+ (and (> (interval-length span-extent) 0)
+ allow-span-bar
+ (set! span-bar
+ (ly:stencil-add
+ span-bar
+ (span-bar::compound-bar-line
+ model-bar
+ bar-glyph
+ span-extent))))))
+ curr))
+ "" extents)
+ (set! span-bar (ly:stencil-translate-axis
+ span-bar
+ (- (ly:grob-relative-coordinate grob refp Y))
+ Y))))
+ span-bar))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; volta bracket functions
(append volta-bracket-allow-volta-hook-list
(list bar-glyph)))
(ly:warning (_ ("Volta hook bar line must be a string; ignoring '~a'.")
- bar-glyph))))
+ bar-glyph))))
(define-session volta-bracket-allow-volta-hook-list '())
;; is the last entry with the same vag-index, so we transform the array to a list,
;; reverse it and search for suitable entries:
(filtered-grobs (filter (lambda (e)
- (eq? (ly:grob-get-vertical-axis-group-index e)
- vag-index))
+ (eq? (ly:grob-get-vertical-axis-group-index e)
+ vag-index))
(reverse (ly:grob-array->list bar-array))))
;; we need the first one (if any)
(right-bar-line (if (pair? filtered-grobs)
(right-bar-broken (or (null? right-bar-line)
(not (zero? (ly:item-break-dir right-bar-line)))))
(left-span-stencil-extent (ly:stencil-extent
+ (span-bar::compound-bar-line
+ left-bar-line
+ left-bar-glyph-name
+ dummy-extent)
+ X))
+ (right-span-stencil-extent (ly:stencil-extent
(span-bar::compound-bar-line
- left-bar-line
- left-bar-glyph-name
- dummy-extent)
+ right-bar-line
+ right-bar-glyph-name
+ dummy-extent)
X))
- (right-span-stencil-extent (ly:stencil-extent
- (span-bar::compound-bar-line
- right-bar-line
- right-bar-glyph-name
- dummy-extent)
- X))
(left-shorten 0.0)
(right-shorten 0.0))
- ;; since "empty" intervals may look like (1.0 . -1.0), we use the
- ;; min/max functions to make sure that the placement is not corrupted
- ;; in case of empty bar lines
- (set! left-shorten
- (if left-bar-broken
- (- (max 0 (interval-end left-span-stencil-extent))
- (max 0 (interval-end (ly:stencil-extent
- (bar-line::compound-bar-line
- left-bar-line
- left-bar-glyph-name
- dummy-extent)
- X)))
- volta-half-line-thickness)
- (- (max 0 (interval-end left-span-stencil-extent))
- volta-half-line-thickness)))
-
- (set! right-shorten
- (if right-bar-broken
- (+ (- (max 0 (interval-end right-span-stencil-extent)))
- volta-half-line-thickness)
- (- (min 0 (interval-start right-span-stencil-extent))
- volta-half-line-thickness)))
-
- (cons left-shorten right-shorten)))
+ ;; since "empty" intervals may look like (1.0 . -1.0), we use the
+ ;; min/max functions to make sure that the placement is not corrupted
+ ;; in case of empty bar lines
+ (set! left-shorten
+ (if left-bar-broken
+ (- (max 0 (interval-end left-span-stencil-extent))
+ (max 0 (interval-end (ly:stencil-extent
+ (bar-line::compound-bar-line
+ left-bar-line
+ left-bar-glyph-name
+ dummy-extent)
+ X)))
+ volta-half-line-thickness)
+ (- (max 0 (interval-end left-span-stencil-extent))
+ volta-half-line-thickness)))
+
+ (set! right-shorten
+ (if right-bar-broken
+ (+ (- (max 0 (interval-end right-span-stencil-extent)))
+ volta-half-line-thickness)
+ (- (min 0 (interval-start right-span-stencil-extent))
+ volta-half-line-thickness)))
+
+ (cons left-shorten right-shorten)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; predefined bar glyph print procedures
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
(define (make-coord x-value y-value)
- "Make a coordinate pair from @var{x-valye} and @var{y-value}."
- (cons x-value y-value))
+ "Make a coordinate pair from @var{x-valye} and @var{y-value}."
+ (cons x-value y-value))
(define (coord+ coord1 coord2)
- "Add @var{coord1} to @var{coord2}, returning a coordinate."
- (cons (+ (car coord1) (car coord2))
- (+ (cdr coord1) (cdr coord2))))
+ "Add @var{coord1} to @var{coord2}, returning a coordinate."
+ (cons (+ (car coord1) (car coord2))
+ (+ (cdr coord1) (cdr coord2))))
(define (coord- coord1 coord2)
- "Subtract @var{coord2} from @var{coord1}."
- (cons (- (car coord1) (car coord2))
- (- (cdr coord1) (cdr coord2))))
+ "Subtract @var{coord2} from @var{coord1}."
+ (cons (- (car coord1) (car coord2))
+ (- (cdr coord1) (cdr coord2))))
(define (coord* scalar coord)
- "Multiply each component of @var{coord} by @var{scalar}."
- (cons (* (car coord) scalar)
- (* (cdr coord) scalar)))
+ "Multiply each component of @var{coord} by @var{scalar}."
+ (cons (* (car coord) scalar)
+ (* (cdr coord) scalar)))
(define (make-bezier point-0 point-1 point-2 point-3)
- "Create a cubic bezier from the four control points."
- (list point-0 point-1 point-2 point-3))
+ "Create a cubic bezier from the four control points."
+ (list point-0 point-1 point-2 point-3))
(define (interpolated-control-points control-points split-value)
- "Interpolate @var{control-points} at @var{split-value}. Return a
+ "Interpolate @var{control-points} at @var{split-value}. Return a
set of control points that is one degree less than @var{control-points}."
(if (null? (cdr control-points))
'()
(let ((first (car control-points))
(second (cadr control-points)))
- (cons* (coord+ first (coord* split-value (coord- second first)))
- (interpolated-control-points
- (cdr control-points)
- split-value)))))
+ (cons* (coord+ first (coord* split-value (coord- second first)))
+ (interpolated-control-points
+ (cdr control-points)
+ split-value)))))
(define (split-bezier bezier split-value)
- "Split a cubic bezier defined by @var{bezier} at the value
+ "Split a cubic bezier defined by @var{bezier} at the value
@var{split-value}. @var{bezier} is a list of pairs; each pair is
is the coordinates of a control point. Returns a list of beziers.
The first element is the LHS spline; the second
element is the RHS spline."
- (let* ((quad-points (interpolated-control-points
+ (let* ((quad-points (interpolated-control-points
bezier
split-value))
- (lin-points (interpolated-control-points
- quad-points
+ (lin-points (interpolated-control-points
+ quad-points
+ split-value))
+ (const-point (interpolated-control-points
+ lin-points
split-value))
- (const-point (interpolated-control-points
- lin-points
- split-value))
- (left-side (list (car bezier)
- (car quad-points)
- (car lin-points)
- (car const-point)))
- (right-side (list (car const-point)
- (list-ref lin-points 1)
- (list-ref quad-points 2)
- (list-ref bezier 3))))
- (cons left-side right-side)))
+ (left-side (list (car bezier)
+ (car quad-points)
+ (car lin-points)
+ (car const-point)))
+ (right-side (list (car const-point)
+ (list-ref lin-points 1)
+ (list-ref quad-points 2)
+ (list-ref bezier 3))))
+ (cons left-side right-side)))
(define (multi-split-bezier bezier start-t split-list)
- "Split @var{bezier} at all the points listed in @var{split-list}.
+ "Split @var{bezier} at all the points listed in @var{split-list}.
@var{bezier} has a parameter value that goes from @var{start-t} to 1.
Returns a list of @var{(1+ (length split-list))} beziers."
(let* ((bezier-split (split-bezier bezier
(define (bezier-sandwich-list top-bezier bottom-bezier)
- "create the list of control points for a bezier sandwich consisting
+ "create the list of control points for a bezier sandwich consisting
of @var{top-bezier} and @var{bottom-bezier}."
- (list (list-ref bottom-bezier 1)
- (list-ref bottom-bezier 2)
- (list-ref bottom-bezier 3)
- (list-ref bottom-bezier 0)
- (list-ref top-bezier 2)
- (list-ref top-bezier 1)
- (list-ref top-bezier 0)
- (list-ref top-bezier 3)))
+ (list (list-ref bottom-bezier 1)
+ (list-ref bottom-bezier 2)
+ (list-ref bottom-bezier 3)
+ (list-ref bottom-bezier 0)
+ (list-ref top-bezier 2)
+ (list-ref top-bezier 1)
+ (list-ref top-bezier 0)
+ (list-ref top-bezier 3)))
(if (null? alist)
"Unknown type"
(if (apply (caar alist) obj)
- (cdar alist)
- (match-predicate obj (cdr alist)))))
+ (cdar alist)
+ (match-predicate obj (cdr alist)))))
(define-public (object-type obj)
(match-predicate obj type-p-name-alist))
Entry point for the parser."
(let* ((flat-mods (flatten-list modifications))
- (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord))
- (complete-chord '())
- (bass #f)
- (inversion #f)
- (lead-mod #f)
- (explicit-11 #f)
- (start-additions #t))
+ (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord))
+ (complete-chord '())
+ (bass #f)
+ (inversion #f)
+ (lead-mod #f)
+ (explicit-11 #f)
+ (start-additions #t))
(define (interpret-inversion chord mods)
"Read /FOO part. Side effect: INVERSION is set."
(if (and (> (length mods) 1) (eq? (car mods) 'chord-slash))
- (begin
- (set! inversion (cadr mods))
- (set! mods (cddr mods))))
+ (begin
+ (set! inversion (cadr mods))
+ (set! mods (cddr mods))))
(interpret-bass chord mods))
(define (interpret-bass chord mods)
"Read /+FOO part. Side effect: BASS is set."
(if (and (> (length mods) 1) (eq? (car mods) 'chord-bass))
- (begin
- (set! bass (cadr mods))
- (set! mods (cddr mods))))
+ (begin
+ (set! bass (cadr mods))
+ (set! mods (cddr mods))))
(if (pair? mods)
- (ly:warning (_ "Spurious garbage following chord: ~A") mods))
+ (ly:warning (_ "Spurious garbage following chord: ~A") mods))
chord)
- (define (interpret-removals chord mods)
+ (define (interpret-removals chord mods)
(define (inner-interpret chord mods)
- (if (and (pair? mods) (ly:pitch? (car mods)))
- (inner-interpret (remove-step (+ 1 (ly:pitch-steps (car mods))) chord)
- (cdr mods))
- (interpret-inversion chord mods)))
+ (if (and (pair? mods) (ly:pitch? (car mods)))
+ (inner-interpret (remove-step (+ 1 (ly:pitch-steps (car mods))) chord)
+ (cdr mods))
+ (interpret-inversion chord mods)))
(if (and (pair? mods) (eq? (car mods) 'chord-caret))
- (inner-interpret chord (cdr mods))
- (interpret-inversion chord mods)))
+ (inner-interpret chord (cdr mods))
+ (interpret-inversion chord mods)))
(define (interpret-additions chord mods)
"Interpret additions. TODO: should restrict modifier use?"
(cond ((null? mods) chord)
- ((ly:pitch? (car mods))
- (if (= (pitch-step (car mods)) 11)
- (set! explicit-11 #t))
- (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord))
- (cdr mods)))
- ((procedure? (car mods))
- (interpret-additions ((car mods) chord)
- (cdr mods)))
- (else (interpret-removals chord mods))))
+ ((ly:pitch? (car mods))
+ (if (= (pitch-step (car mods)) 11)
+ (set! explicit-11 #t))
+ (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord))
+ (cdr mods)))
+ ((procedure? (car mods))
+ (interpret-additions ((car mods) chord)
+ (cdr mods)))
+ (else (interpret-removals chord mods))))
(define (pitch-octavated-strictly-below p root)
- "return P, but octavated, so it is below ROOT"
+ "return P, but octavated, so it is below ROOT"
(ly:make-pitch (+ (ly:pitch-octave root)
- (if (> (ly:pitch-notename root)
- (ly:pitch-notename p))
- 0 -1))
- (ly:pitch-notename p)
- (ly:pitch-alteration p)))
+ (if (> (ly:pitch-notename root)
+ (ly:pitch-notename p))
+ 0 -1))
+ (ly:pitch-notename p)
+ (ly:pitch-alteration p)))
(define (process-inversion complete-chord)
"Take out inversion from COMPLETE-CHORD, and put it at the bottom.
"
(let* ((root (car complete-chord))
- (inv? (lambda (y)
- (and (= (ly:pitch-notename y)
- (ly:pitch-notename inversion))
- (= (ly:pitch-alteration y)
- (ly:pitch-alteration inversion)))))
- (rest-of-chord (remove inv? complete-chord))
- (inversion-candidates (filter inv? complete-chord))
- (down-inversion (pitch-octavated-strictly-below inversion root)))
- (if (pair? inversion-candidates)
- (set! inversion (car inversion-candidates))
- (begin
- (set! bass inversion)
- (set! inversion #f)))
- (if inversion
- (cons down-inversion rest-of-chord)
- rest-of-chord)))
+ (inv? (lambda (y)
+ (and (= (ly:pitch-notename y)
+ (ly:pitch-notename inversion))
+ (= (ly:pitch-alteration y)
+ (ly:pitch-alteration inversion)))))
+ (rest-of-chord (remove inv? complete-chord))
+ (inversion-candidates (filter inv? complete-chord))
+ (down-inversion (pitch-octavated-strictly-below inversion root)))
+ (if (pair? inversion-candidates)
+ (set! inversion (car inversion-candidates))
+ (begin
+ (set! bass inversion)
+ (set! inversion #f)))
+ (if inversion
+ (cons down-inversion rest-of-chord)
+ rest-of-chord)))
;; root is always one octave too low.
;; something weird happens when this is removed,
;; every other chord is octavated. --hwn... hmmm.
(set! root (ly:pitch-transpose root (ly:make-pitch 1 0 0)))
;; skip the leading : , we need some of the stuff following it.
(if (pair? flat-mods)
- (if (eq? (car flat-mods) 'chord-colon)
- (set! flat-mods (cdr flat-mods))
- (set! start-additions #f)))
+ (if (eq? (car flat-mods) 'chord-colon)
+ (set! flat-mods (cdr flat-mods))
+ (set! start-additions #f)))
;; remember modifier
(if (and (pair? flat-mods) (procedure? (car flat-mods)))
- (begin
- (set! lead-mod (car flat-mods))
- (set! flat-mods (cdr flat-mods))))
+ (begin
+ (set! lead-mod (car flat-mods))
+ (set! flat-mods (cdr flat-mods))))
;; extract first number if present, and build pitch list.
(if (and (pair? flat-mods)
- (ly:pitch? (car flat-mods))
- (not (eq? lead-mod sus-modifier)))
- (begin
- (if (= (pitch-step (car flat-mods)) 11)
- (set! explicit-11 #t))
- (set! base-chord
- (stack-thirds (car flat-mods) the-canonical-chord))
- (set! flat-mods (cdr flat-mods))))
+ (ly:pitch? (car flat-mods))
+ (not (eq? lead-mod sus-modifier)))
+ (begin
+ (if (= (pitch-step (car flat-mods)) 11)
+ (set! explicit-11 #t))
+ (set! base-chord
+ (stack-thirds (car flat-mods) the-canonical-chord))
+ (set! flat-mods (cdr flat-mods))))
;; apply modifier
(if (procedure? lead-mod)
- (set! base-chord (lead-mod base-chord)))
+ (set! base-chord (lead-mod base-chord)))
(set! complete-chord
- (if start-additions
- (interpret-additions base-chord flat-mods)
- (interpret-removals base-chord flat-mods)))
+ (if start-additions
+ (interpret-additions base-chord flat-mods)
+ (interpret-removals base-chord flat-mods)))
(set! complete-chord (sort complete-chord ly:pitch<?))
;; If natural 11 + natural 3 is present, but not given explicitly,
;; we remove the 11.
(if (and (not explicit-11)
- (get-step 11 complete-chord)
- (get-step 3 complete-chord)
- (= 0 (ly:pitch-alteration (get-step 11 complete-chord)))
- (= 0 (ly:pitch-alteration (get-step 3 complete-chord))))
- (set! complete-chord (remove-step 11 complete-chord)))
+ (get-step 11 complete-chord)
+ (get-step 3 complete-chord)
+ (= 0 (ly:pitch-alteration (get-step 11 complete-chord)))
+ (= 0 (ly:pitch-alteration (get-step 3 complete-chord))))
+ (set! complete-chord (remove-step 11 complete-chord)))
;; must do before processing inversion/bass, since they are
;; not relative to the root.
(set! complete-chord (map (lambda (x) (ly:pitch-transpose x root))
- complete-chord))
+ complete-chord))
(if inversion
- (set! complete-chord (process-inversion complete-chord)))
+ (set! complete-chord (process-inversion complete-chord)))
(if bass
- (set! bass (pitch-octavated-strictly-below bass root)))
+ (set! bass (pitch-octavated-strictly-below bass root)))
(if #f
- (begin
- (write-me "\n*******\n" flat-mods)
- (write-me "root: " root)
- (write-me "base chord: " base-chord)
- (write-me "complete chord: " complete-chord)
- (write-me "inversion: " inversion)
- (write-me "bass: " bass)))
+ (begin
+ (write-me "\n*******\n" flat-mods)
+ (write-me "root: " root)
+ (write-me "base chord: " base-chord)
+ (write-me "complete chord: " complete-chord)
+ (write-me "inversion: " inversion)
+ (write-me "bass: " bass)))
(if inversion
- (make-chord-elements (cdr complete-chord) bass duration (car complete-chord)
- inversion)
- (make-chord-elements complete-chord bass duration #f #f))))
+ (make-chord-elements (cdr complete-chord) bass duration (car complete-chord)
+ inversion)
+ (make-chord-elements complete-chord bass duration #f #f))))
(define (make-chord-elements pitches bass duration inversion original-inv-pitch)
'duration duration
'pitch pitch))
(let ((nots (map make-note-ev pitches))
- (bass-note (if bass (make-note-ev bass) #f))
- (inv-note (if inversion (make-note-ev inversion) #f)))
+ (bass-note (if bass (make-note-ev bass) #f))
+ (inv-note (if inversion (make-note-ev inversion) #f)))
(if bass-note
- (begin
- (set! (ly:music-property bass-note 'bass) #t)
- (set! nots (cons bass-note nots))))
+ (begin
+ (set! (ly:music-property bass-note 'bass) #t)
+ (set! nots (cons bass-note nots))))
(if inv-note
- (begin
- (set! (ly:music-property inv-note 'inversion) #t)
- (set! (ly:music-property inv-note 'octavation)
- (- (ly:pitch-octave inversion)
- (ly:pitch-octave original-inv-pitch)))
- (set! nots (cons inv-note nots))))
+ (begin
+ (set! (ly:music-property inv-note 'inversion) #t)
+ (set! (ly:music-property inv-note 'octavation)
+ (- (ly:pitch-octave inversion)
+ (ly:pitch-octave original-inv-pitch)))
+ (set! nots (cons inv-note nots))))
nots))
;;;;;;;;;;;;;;;;
;; canonical 13 chord.
(define the-canonical-chord
(map (lambda (n)
- (define (nca x)
- (if (= x 7) FLAT 0))
+ (define (nca x)
+ (if (= x 7) FLAT 0))
- (if (>= n 8)
- (ly:make-pitch 1 (- n 8) (nca n))
- (ly:make-pitch 0 (- n 1) (nca n))))
+ (if (>= n 8)
+ (ly:make-pitch 1 (- n 8) (nca n))
+ (ly:make-pitch 0 (- n 1) (nca n))))
'(1 3 5 7 9 11 13)))
(define (stack-thirds upper-step base)
"Stack thirds listed in BASE until we reach UPPER-STEP. Add
UPPER-STEP separately."
(cond ((null? base) '())
- ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
- (cons (car base) (stack-thirds upper-step (cdr base))))
- ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
- (list upper-step))
- (else '())))
+ ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
+ (cons (car base) (stack-thirds upper-step (cdr base))))
+ ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
+ (list upper-step))
+ (else '())))
(define (default-note-namer pitch)
- (note-name->markup pitch #f))
+ (note-name->markup pitch #f))
(define (markup-or-empty-markup markup)
"Return MARKUP if markup, else empty-markup"
(if bool
(make-line-markup
(list (make-hspace-markup amount)
- markup))
+ markup))
markup))
(define-public (banter-chord-names pitches bass inversion context)
'jazz pitches bass inversion context '()))
(define-public (ugh-compat-double-plus-new-chord->markup
- style pitches bass inversion context options)
+ style pitches bass inversion context options)
"Entry point for @code{New_chord_name_engraver}.
FIXME: func, options/context have changed
(define (step-nr pitch)
(let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
- (ly:pitch-notename pitch)))
- (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
- (ly:pitch-notename (car pitches)))))
+ (ly:pitch-notename pitch)))
+ (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
+ (ly:pitch-notename (car pitches)))))
(+ 1 (- pitch-nr root-nr))))
(define (next-third pitch)
(ly:pitch-transpose pitch
- (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
- (= (step-nr pitch) 5))
- FLAT 0))))
+ (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
+ (= (step-nr pitch) 5))
+ FLAT 0))))
(define (step-alteration pitch)
(let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
- (normalized-pitch (ly:pitch-transpose pitch diff))
- (alteration (ly:pitch-alteration normalized-pitch)))
+ (normalized-pitch (ly:pitch-transpose pitch diff))
+ (alteration (ly:pitch-alteration normalized-pitch)))
(if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
(define (pitch-unalter pitch)
(let ((alteration (step-alteration pitch)))
(if (= alteration 0)
- pitch
- (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
- (- (ly:pitch-alteration pitch) alteration)))))
+ pitch
+ (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
+ (- (ly:pitch-alteration pitch) alteration)))))
(define (step-even-or-altered? pitch)
(let ((nr (step-nr pitch)))
(if (!= (modulo nr 2) 0)
- (!= (step-alteration pitch) 0)
- #t)))
+ (!= (step-alteration pitch) 0)
+ #t)))
(define (step->markup-plusminus pitch)
(make-line-markup
(make-simple-markup (number->string (step-nr pitch)))
(make-simple-markup
(case (step-alteration pitch)
- ((DOUBLE-FLAT) "--")
- ((FLAT) "-")
- ((NATURAL) "")
- ((SHARP) "+")
- ((DOUBLE-SHARP) "++"))))))
+ ((DOUBLE-FLAT) "--")
+ ((FLAT) "-")
+ ((NATURAL) "")
+ ((SHARP) "+")
+ ((DOUBLE-SHARP) "++"))))))
(define (step->markup-accidental pitch)
(make-line-markup
(list (accidental->markup (step-alteration pitch))
- (make-simple-markup (number->string (step-nr pitch))))))
+ (make-simple-markup (number->string (step-nr pitch))))))
(define (step->markup-ignatzek pitch)
(make-line-markup
(if (and (= (step-nr pitch) 7)
- (= (step-alteration pitch) 1))
- (list (ly:context-property context 'majorSevenSymbol))
- (list (accidental->markup (step-alteration pitch))
- (make-simple-markup (number->string (step-nr pitch)))))))
+ (= (step-alteration pitch) 1))
+ (list (ly:context-property context 'majorSevenSymbol))
+ (list (accidental->markup (step-alteration pitch))
+ (make-simple-markup (number->string (step-nr pitch)))))))
;; tja, kennok
(define (make-sub->markup step->markup)
(lambda (pitch)
(make-line-markup (list (make-simple-markup "no")
- (step->markup pitch)))))
+ (step->markup pitch)))))
(define (step-based-sub->markup step->markup pitch)
(make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
(define (get-full-list pitch)
(if (<= (step-nr pitch) (step-nr (last pitches)))
- (cons pitch (get-full-list (next-third pitch)))
- '()))
+ (cons pitch (get-full-list (next-third pitch)))
+ '()))
(define (get-consecutive nr pitches)
(if (pair? pitches)
- (let* ((pitch-nr (step-nr (car pitches)))
- (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
- (if (<= pitch-nr nr)
- (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
- '()))
- '()))
+ (let* ((pitch-nr (step-nr (car pitches)))
+ (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
+ (if (<= pitch-nr nr)
+ (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
+ '()))
+ '()))
(define (full-match exceptions)
(if (pair? exceptions)
- (let* ((e (car exceptions))
- (e-pitches (car e)))
- (if (equal? e-pitches pitches)
- e
- (full-match (cdr exceptions))))
- #f))
+ (let* ((e (car exceptions))
+ (e-pitches (car e)))
+ (if (equal? e-pitches pitches)
+ e
+ (full-match (cdr exceptions))))
+ #f))
(define (partial-match exceptions)
(if (pair? exceptions)
- (let* ((e (car exceptions))
- (e-pitches (car e)))
- (if (equal? e-pitches (take pitches (length e-pitches)))
- e
- (partial-match (cdr exceptions))))
- #f))
+ (let* ((e (car exceptions))
+ (e-pitches (car e)))
+ (if (equal? e-pitches (take pitches (length e-pitches)))
+ e
+ (partial-match (cdr exceptions))))
+ #f))
(if #f (begin
- (write-me "pitches: " pitches)))
+ (write-me "pitches: " pitches)))
(let* ((full-exceptions
- (ly:context-property context 'chordNameExceptionsFull))
- (full-exception (full-match full-exceptions))
- (full-markup (if full-exception (cadr full-exception) '()))
- (partial-exceptions
- (ly:context-property context 'chordNameExceptionsPartial))
- (partial-exception (partial-match partial-exceptions))
- (partial-pitches (if partial-exception (car partial-exception) '()))
- (partial-markup-prefix
- (if partial-exception (markup-or-empty-markup
- (cadr partial-exception)) empty-markup))
- (partial-markup-suffix
- (if (and partial-exception (pair? (cddr partial-exception)))
- (markup-or-empty-markup (caddr partial-exception)) empty-markup))
- (root (car pitches))
- (full (get-full-list root))
- ;; kludge alert: replace partial matched lower part of all with
- ;; 'normal' pitches from full
- ;; (all pitches)
- (all (append (take full (length partial-pitches))
- (drop pitches (length partial-pitches))))
-
- (highest (last all))
- (missing (list-minus full (map pitch-unalter all)))
- (consecutive (get-consecutive 1 all))
- (rest (list-minus all consecutive))
- (altered (filter step-even-or-altered? all))
- (cons-alt (filter step-even-or-altered? consecutive))
- (base (list-minus consecutive altered)))
+ (ly:context-property context 'chordNameExceptionsFull))
+ (full-exception (full-match full-exceptions))
+ (full-markup (if full-exception (cadr full-exception) '()))
+ (partial-exceptions
+ (ly:context-property context 'chordNameExceptionsPartial))
+ (partial-exception (partial-match partial-exceptions))
+ (partial-pitches (if partial-exception (car partial-exception) '()))
+ (partial-markup-prefix
+ (if partial-exception (markup-or-empty-markup
+ (cadr partial-exception)) empty-markup))
+ (partial-markup-suffix
+ (if (and partial-exception (pair? (cddr partial-exception)))
+ (markup-or-empty-markup (caddr partial-exception)) empty-markup))
+ (root (car pitches))
+ (full (get-full-list root))
+ ;; kludge alert: replace partial matched lower part of all with
+ ;; 'normal' pitches from full
+ ;; (all pitches)
+ (all (append (take full (length partial-pitches))
+ (drop pitches (length partial-pitches))))
+
+ (highest (last all))
+ (missing (list-minus full (map pitch-unalter all)))
+ (consecutive (get-consecutive 1 all))
+ (rest (list-minus all consecutive))
+ (altered (filter step-even-or-altered? all))
+ (cons-alt (filter step-even-or-altered? consecutive))
+ (base (list-minus consecutive altered)))
(if #f (begin
- (write-me "full:" full)
- ;; (write-me "partial-pitches:" partial-pitches)
- (write-me "full-markup:" full-markup)
- (write-me "partial-markup-perfix:" partial-markup-prefix)
- (write-me "partial-markup-suffix:" partial-markup-suffix)
- (write-me "all:" all)
- (write-me "altered:" altered)
- (write-me "missing:" missing)
- (write-me "consecutive:" consecutive)
- (write-me "rest:" rest)
- (write-me "base:" base)))
+ (write-me "full:" full)
+ ;; (write-me "partial-pitches:" partial-pitches)
+ (write-me "full-markup:" full-markup)
+ (write-me "partial-markup-perfix:" partial-markup-prefix)
+ (write-me "partial-markup-suffix:" partial-markup-suffix)
+ (write-me "all:" all)
+ (write-me "altered:" altered)
+ (write-me "missing:" missing)
+ (write-me "consecutive:" consecutive)
+ (write-me "rest:" rest)
+ (write-me "base:" base)))
(case style
((banter)
;; + subs:missing
(let* ((root->markup (assoc-get
- 'root->markup options default-note-namer))
- (step->markup (assoc-get
- 'step->markup options step->markup-plusminus))
- (sub->markup (assoc-get
- 'sub->markup options
- (lambda (x)
- (step-based-sub->markup step->markup x))))
- (sep (assoc-get
- 'separator options (make-simple-markup "/"))))
-
- (if
- (pair? full-markup)
- (make-line-markup (list (root->markup root) full-markup))
-
- (make-line-markup
- (list
- (root->markup root)
- partial-markup-prefix
- (make-normal-size-super-markup
- (markup-join
- (apply append
- (map step->markup
- (append altered
- (if (and (> (step-nr highest) 5)
- (not
- (step-even-or-altered? highest)))
- (list highest) '())))
- (list partial-markup-suffix)
- (list (map sub->markup missing)))
- sep)))))))
+ 'root->markup options default-note-namer))
+ (step->markup (assoc-get
+ 'step->markup options step->markup-plusminus))
+ (sub->markup (assoc-get
+ 'sub->markup options
+ (lambda (x)
+ (step-based-sub->markup step->markup x))))
+ (sep (assoc-get
+ 'separator options (make-simple-markup "/"))))
+
+ (if
+ (pair? full-markup)
+ (make-line-markup (list (root->markup root) full-markup))
+
+ (make-line-markup
+ (list
+ (root->markup root)
+ partial-markup-prefix
+ (make-normal-size-super-markup
+ (markup-join
+ (apply append
+ (map step->markup
+ (append altered
+ (if (and (> (step-nr highest) 5)
+ (not
+ (step-even-or-altered? highest)))
+ (list highest) '())))
+ (list partial-markup-suffix)
+ (list (map sub->markup missing)))
+ sep)))))))
((jazz)
;; + 'add'
;; + steps:rest
(let* ((root->markup (assoc-get
- 'root->markup options default-note-namer))
- (step->markup
- (assoc-get
- ;; FIXME: ignatzek
- ;;'step->markup options step->markup-accidental))
- 'step->markup options step->markup-ignatzek))
- (sep (assoc-get
- 'separator options (make-simple-markup " ")))
- (add-prefix (assoc-get 'add-prefix options
- (make-simple-markup " add"))))
-
- (if
- (pair? full-markup)
- (make-line-markup (list (root->markup root) full-markup))
-
- (make-line-markup
- (list
- (root->markup root)
- partial-markup-prefix
- (make-normal-size-super-markup
- (make-line-markup
- (list
-
- ;; kludge alert: omit <= 5
- ;;(markup-join (map step->markup
- ;; (cons (last base) cons-alt)) sep)
-
- ;; This fixes:
- ;; c C5 -> C
- ;; c:2 C5 2 -> C2
- ;; c:3- Cm5 -> Cm
- ;; c:6.9 C5 6add9 -> C6 add 9 (add?)
- ;; ch = \chords { c c:2 c:3- c:6.9^7 }
- (markup-join (map step->markup
- (let ((tb (last base)))
- (if (> (step-nr tb) 5)
- (cons tb cons-alt)
- cons-alt))) sep)
-
- (if (pair? rest)
- add-prefix
- empty-markup)
- (markup-join (map step->markup rest) sep)
- partial-markup-suffix))))))))
-
- (else empty-markup))))
+ 'root->markup options default-note-namer))
+ (step->markup
+ (assoc-get
+ ;; FIXME: ignatzek
+ ;;'step->markup options step->markup-accidental))
+ 'step->markup options step->markup-ignatzek))
+ (sep (assoc-get
+ 'separator options (make-simple-markup " ")))
+ (add-prefix (assoc-get 'add-prefix options
+ (make-simple-markup " add"))))
+
+ (if
+ (pair? full-markup)
+ (make-line-markup (list (root->markup root) full-markup))
+
+ (make-line-markup
+ (list
+ (root->markup root)
+ partial-markup-prefix
+ (make-normal-size-super-markup
+ (make-line-markup
+ (list
+
+ ;; kludge alert: omit <= 5
+ ;;(markup-join (map step->markup
+ ;; (cons (last base) cons-alt)) sep)
+
+ ;; This fixes:
+ ;; c C5 -> C
+ ;; c:2 C5 2 -> C2
+ ;; c:3- Cm5 -> Cm
+ ;; c:6.9 C5 6add9 -> C6 add 9 (add?)
+ ;; ch = \chords { c c:2 c:3- c:6.9^7 }
+ (markup-join (map step->markup
+ (let ((tb (last base)))
+ (if (> (step-nr tb) 5)
+ (cons tb cons-alt)
+ cons-alt))) sep)
+
+ (if (pair? rest)
+ add-prefix
+ empty-markup)
+ (markup-join (map step->markup rest) sep)
+ partial-markup-suffix))))))))
+
+ (else empty-markup))))
(make-smaller-markup
(make-raise-markup
(if (= alteration FLAT)
- 0.3
- 0.6)
+ 0.3
+ 0.6)
(make-musicglyph-markup
(assoc-get alteration standard-alteration-glyph-name-alist "")))))
(make-line-markup
(list
(make-hspace-markup (if (= alteration FLAT) 0.57285385 0.5))
- (make-raise-markup 0.7 (alteration->text-accidental-markup alteration))
- (make-hspace-markup (if (= alteration SHARP) 0.2 0.1))
- ))))
+ (make-raise-markup 0.7 (alteration->text-accidental-markup alteration))
+ (make-hspace-markup (if (= alteration SHARP) 0.2 0.1))
+ ))))
(define-public (note-name->markup pitch lowercase?)
"Return pitch markup for @var{pitch}."
(inexact->exact (round (* (ly:pitch-alteration pitch) 2))))
(define-safe-public ((chord-name->german-markup B-instead-of-Bb)
- pitch lowercase?)
+ pitch lowercase?)
"Return pitch markup for PITCH, using german note names.
If B-instead-of-Bb is set to #t real german names are returned.
Otherwise semi-german names (with Bb and below keeping the british names)
"
(let* ((name (ly:pitch-notename pitch))
(alt-semitones (pitch-alteration-semitones pitch))
- (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2)))
- (cons 7 (+ (if B-instead-of-Bb 1 0) alt-semitones))
- (cons name alt-semitones))))
+ (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2)))
+ (cons 7 (+ (if B-instead-of-Bb 1 0) alt-semitones))
+ (cons name alt-semitones))))
(make-line-markup
(list
(make-simple-markup
(conditional-string-downcase
- (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a))
- lowercase?))
+ (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a))
+ lowercase?))
(make-normal-size-super-markup
(accidental->markup (/ (cdr n-a) 2)))))))
(define-safe-public (note-name->german-markup pitch lowercase?)
(let* ((name (ly:pitch-notename pitch))
- (alt-semitones (pitch-alteration-semitones pitch))
- (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2)))
- (cons 7 (+ 1 alt-semitones))
- (cons name alt-semitones))))
+ (alt-semitones (pitch-alteration-semitones pitch))
+ (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2)))
+ (cons 7 (+ 1 alt-semitones))
+ (cons name alt-semitones))))
(make-line-markup
(list
(string-append
(list-ref '("c" "d" "e" "f" "g" "a" "h" "b") (car n-a))
(if (or (equal? (car n-a) 2) (equal? (car n-a) 5))
- (list-ref '( "ses" "s" "" "is" "isis") (+ 2 (cdr n-a)))
- (list-ref '("eses" "es" "" "is" "isis") (+ 2 (cdr n-a)))))))))
+ (list-ref '( "ses" "s" "" "is" "isis") (+ 2 (cdr n-a)))
+ (list-ref '("eses" "es" "" "is" "isis") (+ 2 (cdr n-a)))))))))
(define-public ((chord-name->italian-markup re-with-eacute) pitch lowercase?)
"Return pitch markup for @var{pitch}, using Italian/@/French note names.
(list
(make-simple-markup
(conditional-string-downcase
- (vector-ref
- (if re-with-eacute
- #("Do" "Ré" "Mi" "Fa" "Sol" "La" "Si")
- #("Do" "Re" "Mi" "Fa" "Sol" "La" "Si"))
- name)
- lowercase?))
+ (vector-ref
+ (if re-with-eacute
+ #("Do" "Ré" "Mi" "Fa" "Sol" "La" "Si")
+ #("Do" "Re" "Mi" "Fa" "Sol" "La" "Si"))
+ name)
+ lowercase?))
(accidental->markup-italian alt)
))))
(define (chord-to-exception-entry m)
(let* ((elts (ly:music-property m 'elements))
- (omit-root (and (pair? rest) (car rest)))
- (pitches (map (lambda (x) (ly:music-property x 'pitch))
- (filter
- (lambda (y) (memq 'note-event
- (ly:music-property y 'types)))
- elts)))
- (sorted (sort pitches ly:pitch<?))
- (root (car sorted))
-
- ;; ugh?
- ;;(diff (ly:pitch-diff root (ly:make-pitch -1 0 0)))
- ;; FIXME. This results in #<Pitch c> ...,
- ;; but that is what we need because default octave for
- ;; \chords has changed to c' too?
- (diff (ly:pitch-diff root (ly:make-pitch 0 0 0)))
- (normalized (map (lambda (x) (ly:pitch-diff x diff)) sorted))
- (texts (map (lambda (x) (ly:music-property x 'text))
- (filter
- (lambda (y) (memq 'text-script-event
- (ly:music-property y 'types)))
- elts)))
-
- (text (if (null? texts) #f (if omit-root (car texts) texts))))
+ (omit-root (and (pair? rest) (car rest)))
+ (pitches (map (lambda (x) (ly:music-property x 'pitch))
+ (filter
+ (lambda (y) (memq 'note-event
+ (ly:music-property y 'types)))
+ elts)))
+ (sorted (sort pitches ly:pitch<?))
+ (root (car sorted))
+
+ ;; ugh?
+ ;;(diff (ly:pitch-diff root (ly:make-pitch -1 0 0)))
+
;; FIXME. This results in #<Pitch c> ...,
+ ;; but that is what we need because default octave for
+ ;; \chords has changed to c' too?
+ (diff (ly:pitch-diff root (ly:make-pitch 0 0 0)))
+ (normalized (map (lambda (x) (ly:pitch-diff x diff)) sorted))
+ (texts (map (lambda (x) (ly:music-property x 'text))
+ (filter
+ (lambda (y) (memq 'text-script-event
+ (ly:music-property y 'types)))
+ elts)))
+
+ (text (if (null? texts) #f (if omit-root (car texts) texts))))
(cons (if omit-root (cdr normalized) normalized) text)))
(define (is-event-chord? m)
(not (equal? ZERO-MOMENT (ly:music-length m)))))
(let* ((elts (filter is-event-chord? (ly:music-property seq 'elements)))
- (alist (map chord-to-exception-entry elts)))
+ (alist (map chord-to-exception-entry elts)))
(filter (lambda (x) (cdr x)) alist)))
-
;; scm/output-lib.scm
;;
;;
-;; (define-public (make-rhythmic-location bar-num num den)
-;; (define-public (rhythmic-location? a)
-;; (define-public (make-graceless-rhythmic-location loc)
-;; (define-public rhythmic-location-measure-position cdr)
-;; (define-public rhythmic-location-bar-number car)
-;; (define-public (rhythmic-location<? a b)
-;; (define-public (rhythmic-location<=? a b)
-;; (define-public (rhythmic-location>=? a b)
-;; (define-public (rhythmic-location>? a b)
-;; (define-public (rhythmic-location=? a b)
-;; (define-public (rhythmic-location->file-string a)
-;; (define-public (rhythmic-location->string a)
+;; (define-public (make-rhythmic-location bar-num num den)
+;; (define-public (rhythmic-location? a)
+;; (define-public (make-graceless-rhythmic-location loc)
+;; (define-public rhythmic-location-measure-position cdr)
+;; (define-public rhythmic-location-bar-number car)
+;; (define-public (rhythmic-location<? a b)
+;; (define-public (rhythmic-location<=? a b)
+;; (define-public (rhythmic-location>=? a b)
+;; (define-public (rhythmic-location>? a b)
+;; (define-public (rhythmic-location=? a b)
+;; (define-public (rhythmic-location->file-string a)
+;; (define-public (rhythmic-location->string a)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(region-end (cdr clip-region))
(found-grace-end #f)
(candidate-columns
- (filter
- (lambda (j)
- (let*
- ((column (ly:grob-array-ref columns j))
- (loc (ly:grob-property column 'rhythmic-location))
- (grace-less (make-graceless-rhythmic-location loc))
- )
+ (filter
+ (lambda (j)
+ (let*
+ ((column (ly:grob-array-ref columns j))
+ (loc (ly:grob-property column 'rhythmic-location))
+ (grace-less (make-graceless-rhythmic-location loc))
+ )
- (and (rhythmic-location? loc)
- (rhythmic-location<=? region-start loc)
- (or (rhythmic-location<? grace-less region-end)
- (and (rhythmic-location=? grace-less region-end)
- (eq? #t (ly:grob-property column 'non-musical))
+ (and (rhythmic-location? loc)
+ (rhythmic-location<=? region-start loc)
+ (or (rhythmic-location<? grace-less region-end)
+ (and (rhythmic-location=? grace-less region-end)
+ (eq? #t (ly:grob-property column 'non-musical))
- )))
+ )))
- ))
+ ))
- (iota (ly:grob-array-length columns))))
+ (iota (ly:grob-array-length columns))))
(column-range
- (if (>= 1 (length candidate-columns))
- #f
- (cons (car candidate-columns)
- (car (last-pair candidate-columns)))))
+ (if (>= 1 (length candidate-columns))
+ #f
+ (cons (car candidate-columns)
+ (car (last-pair candidate-columns)))))
(clipped-x-interval
- (if column-range
- (cons
-
- (interval-start
- (ly:grob-robust-relative-extent
- (if (= 0 (car column-range))
- system-grob
- (ly:grob-array-ref columns (car column-range)))
- system-grob X))
-
- (interval-end
- (ly:grob-robust-relative-extent
- (if (= (1- (ly:grob-array-length columns)) (cdr column-range))
- system-grob
- (ly:grob-array-ref columns (cdr column-range)))
- system-grob X)))
-
-
- #f
- )))
+ (if column-range
+ (cons
+
+ (interval-start
+ (ly:grob-robust-relative-extent
+ (if (= 0 (car column-range))
+ system-grob
+ (ly:grob-array-ref columns (car column-range)))
+ system-grob X))
+
+ (interval-end
+ (ly:grob-robust-relative-extent
+ (if (= (1- (ly:grob-array-length columns)) (cdr column-range))
+ system-grob
+ (ly:grob-array-ref columns (cdr column-range)))
+ system-grob X)))
+
+
+ #f
+ )))
clipped-x-interval))
(define-module (scm coverage))
(use-modules (lily)
- (ice-9 rdelim)
- (ice-9 regex)
- (ice-9 format) ;; needed for ~8@
- )
+ (ice-9 rdelim)
+ (ice-9 regex)
+ (ice-9 format) ;; needed for ~8@
+ )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (coverage:show-all filter?)
(let*
((keys
- (filter filter?
- (sort (map car (hash-table->alist coverage-table)) string<? ))))
-
- (newline)
- (for-each
- (lambda (k)
+ (filter filter?
+ (sort (map car (hash-table->alist coverage-table)) string<? ))))
- (format #t "Coverage for file: ~a\n" k)
- (display-coverage
- k (hash-ref coverage-table k)
- (format #f "~a.cov" (basename k))))
- keys)))
+ (newline)
+ (for-each
+ (lambda (k)
+
+ (format #t "Coverage for file: ~a\n" k)
+ (display-coverage
+ k (hash-ref coverage-table k)
+ (format #f "~a.cov" (basename k))))
+ keys)))
(define-public (coverage:enable)
(trap-enable 'memoize-symbol)
(trap-enable 'traps))
-
+
(define-public (coverage:disable)
(trap-set! memoize-symbol-handler #f)
(trap-disable 'memoize-symbol))
((lines (read-lines (open-file file "r")))
(format-str "~8@a: ~5@a:~a\n")
(out (if out-file (open-output-file out-file)
- (current-output-port))))
+ (current-output-port))))
(format out format-str "-" 0 (format #f "Source:~a" file))
(do
- ((i 0 (1+ i))
- (l lines (cdr l)))
- ((or (null? l) ))
+ ((i 0 (1+ i))
+ (l lines (cdr l)))
+ ((or (null? l) ))
(format out format-str
- (cond
- ((and (< i (vector-length vec)) (vector-ref vec i)) "1")
- ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l)))
- "-")
- ((string-match "^[ \t]*[()'`,]*$" (car l))
- "-")
- ((string-match "^[ \t]*;.*$" (car l))
-
- "-")
- (else "0"))
- (1+ i)
- (car l)))))
+ (cond
+ ((and (< i (vector-length vec)) (vector-ref vec i)) "1")
+ ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l)))
+ "-")
+ ((string-match "^[ \t]*[()'`,]*$" (car l))
+ "-")
+ ((string-match "^[ \t]*;.*$" (car l))
+
+ "-")
+ (else "0"))
+ (1+ i)
+ (car l)))))
(define (record-coverage key cont exp env)
(let*
(vec (and name (hash-ref coverage-table name #f)))
(veclen (and vec (vector-length vec)))
(veccopy (lambda (src dst)
- (vector-move-left! src 0 (vector-length src)
- dst 0)
- dst)))
+ (vector-move-left! src 0 (vector-length src)
+ dst 0)
+ dst)))
(if (and line name)
- (begin
- (if (or (not vec) (>= line (vector-length vec)))
- (set! vec
- (hash-set! coverage-table name
- (if vec
- (veccopy vec (make-vector (1+ line) #f))
- (make-vector (1+ line) #f)))))
-
- (vector-set! vec line #t))
- )))
-
-
-
-
-
+ (begin
+ (if (or (not vec) (>= line (vector-length vec)))
+ (set! vec
+ (hash-set! coverage-table name
+ (if vec
+ (veccopy vec (make-vector (1+ line) #f))
+ (make-vector (1+ line) #f)))))
+
+ (vector-set! vec line #t))
+ )))
(define (translator-property-description symbol type? description)
(if (not (and
- (symbol? symbol)
- (procedure? type?)
- (string? description)))
+ (symbol? symbol)
+ (procedure? type?)
+ (string? description)))
(throw 'init-format-error))
(define-public all-translation-properties
(append all-user-translation-properties
- all-internal-translation-properties))
+ all-internal-translation-properties))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define event-classes
'((() . (StreamEvent))
(StreamEvent .
- (RemoveContext
- ChangeParent Override Revert UnsetProperty SetProperty
- music-event OldMusicEvent CreateContext Prepare
- OneTimeStep Finish))
+ (RemoveContext
+ ChangeParent Override Revert UnsetProperty SetProperty
+ music-event OldMusicEvent CreateContext Prepare
+ OneTimeStep Finish))
(music-event . (annotate-output-event
footnote-event arpeggio-event breathing-event
extender-event span-event rhythmic-event dynamic-event
(pedal-event . (sostenuto-event sustain-event una-corda-event))
(rhythmic-event . (lyric-event
melodic-event multi-measure-rest-event
- double-percent-event percent-event
- repeat-slash-event rest-event
- skip-event bass-figure-event))
+ double-percent-event percent-event
+ repeat-slash-event rest-event
+ skip-event bass-figure-event))
(melodic-event . (cluster-note-event note-event))
(() . (Announcement))
(Announcement . (AnnounceNewContext))
(define-public (event-class-cons class parent classlist)
(let ((lineage (assq parent classlist)))
(if (not lineage)
- (begin
- (if (not (null? parent))
- (ly:warning (_ "unknown parent class `~a'") parent))
- (set! lineage '())))
+ (begin
+ (if (not (null? parent))
+ (ly:warning (_ "unknown parent class `~a'") parent))
+ (set! lineage '())))
(if (symbol? class)
- (acons class lineage classlist)
- (fold (lambda (elt alist)
- (acons elt lineage alist))
- classlist class))))
+ (acons class lineage classlist)
+ (fold (lambda (elt alist)
+ (acons elt lineage alist))
+ classlist class))))
;; Each class will be defined as
;; (class parent grandparent .. )
(define-public all-event-classes
(fold (lambda (elt classlist)
- (event-class-cons (cdr elt) (car elt) classlist))
- '() event-classes))
+ (event-class-cons (cdr elt) (car elt) classlist))
+ '() event-classes))
;; does this exist in guile already?
(define (map-tree f t)
(define (expand-event-tree root)
(let ((children (assq root event-classes)))
(if children
- (cons root (map expand-event-tree (cdr children)))
- root)))
+ (cons root (map expand-event-tree (cdr children)))
+ root)))
;; produce neater representation of music event tree.
;; TODO: switch to this representation for the event-classes list?
(define music-event-tree (expand-event-tree 'music-event))
(define (sort-tree t)
(define (stringify el)
- (if (symbol? el)
- (symbol->string el)
- (symbol->string (first el))))
+ (if (symbol? el)
+ (symbol->string el)
+ (symbol->string (first el))))
(if (list? t)
(sort (map (lambda (el)
- (if (list? el)
- (cons (car el) (sort-tree (cdr el)))
- el))
- t)
- (lambda (a b) (string<? (stringify a) (stringify b))))
+ (if (list? el)
+ (cons (car el) (sort-tree (cdr el)))
+ el))
+ t)
+ (lambda (a b) (string<? (stringify a) (stringify b))))
t))
;;(use-modules (ice-9 pretty-print))
;; Special case for lists reduces stack consumption.
((list? e) (map simplify e))
((pair? e) (cons (simplify (car e))
- (simplify (cdr e))))
+ (simplify (cdr e))))
((ly:stream-event? e)
(list 'unquote (list 'make-stream-event (simplify (Stream_event::dump e)))))
((ly:music? e)
(list 'unquote (music->make-music e)))
((ly:moment? e)
(list 'unquote `(ly:make-moment
- ,(ly:moment-main-numerator e)
- ,(ly:moment-main-denominator e)
- . ,(if (zero? (ly:moment-grace-numerator e))
- '()
- (list (ly:moment-grace-numerator e)
- (ly:moment-grace-denominator e))))))
+ ,(ly:moment-main-numerator e)
+ ,(ly:moment-main-denominator e)
+ . ,(if (zero? (ly:moment-grace-numerator e))
+ '()
+ (list (ly:moment-grace-numerator e)
+ (ly:moment-grace-denominator e))))))
((ly:duration? e)
(list 'unquote `(ly:make-duration
- ,(ly:duration-log e)
- ,(ly:duration-dot-count e)
- ,(ly:duration-scale))))
+ ,(ly:duration-log e)
+ ,(ly:duration-dot-count e)
+ ,(ly:duration-scale))))
((ly:pitch? e)
(list 'unquote `(ly:make-pitch
- ,(ly:pitch-octave e)
- ,(ly:pitch-notename e)
- ,(ly:pitch-alteration e))))
+ ,(ly:pitch-octave e)
+ ,(ly:pitch-notename e)
+ ,(ly:pitch-alteration e))))
((ly:input-location? e)
(list 'unquote '(ly:dummy-input-location)))
(#t e)))
(ly:add-interface
'clef-modifier-interface
- "The number describing transposition of the clef, placed below
+ "The number describing transposition of the clef, placed below
or above clef sign. Usually this is 8 (octave transposition)
or 15 (two octaves), but LilyPond allows any integer here."
- '())
+ '())
(ly:add-interface
'dynamic-interface
thickness))
(ly:add-interface
- 'glissando-interface
- "A glissando."
- '(glissando-index))
+ 'glissando-interface
+ "A glissando."
+ '(glissando-index))
(ly:add-interface
'grace-spacing-interface
;;; t
;;;
(text ,markup? "Text markup. See @ruser{Formatting text}.")
-;;FIXME -- Should both be the same?
+ ;;FIXME -- Should both be the same?
(text-direction ,ly:dir? "This controls the ordering of the
words. The default @code{RIGHT} is for roman text. Arabic or Hebrew
should use @code{LEFT}.")
`(
(Accidental
. (
- (alteration . ,accidental-interface::calc-alteration)
- (avoid-slur . inside)
- (glyph-name . ,accidental-interface::glyph-name)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (stencil . ,ly:accidental-interface::print)
- (horizontal-skylines . ,(ly:make-unpure-pure-container ly:accidental-interface::horizontal-skylines))
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (X-extent . ,ly:accidental-interface::width)
- (Y-extent . ,accidental-interface::height)
- (meta . ((class . Item)
- (interfaces . (accidental-interface
- inline-accidental-interface
- font-interface))))))
+ (alteration . ,accidental-interface::calc-alteration)
+ (avoid-slur . inside)
+ (glyph-name . ,accidental-interface::glyph-name)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (stencil . ,ly:accidental-interface::print)
+ (horizontal-skylines . ,(ly:make-unpure-pure-container ly:accidental-interface::horizontal-skylines))
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (X-extent . ,ly:accidental-interface::width)
+ (Y-extent . ,accidental-interface::height)
+ (meta . ((class . Item)
+ (interfaces . (accidental-interface
+ inline-accidental-interface
+ font-interface))))))
(AccidentalCautionary
. (
- (alteration . ,accidental-interface::calc-alteration)
- (avoid-slur . inside)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (parenthesized . #t)
- (stencil . ,ly:accidental-interface::print)
- (Y-extent . ,accidental-interface::height)
- (meta . ((class . Item)
- (interfaces . (accidental-interface
- inline-accidental-interface
- font-interface))))))
+ (alteration . ,accidental-interface::calc-alteration)
+ (avoid-slur . inside)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (parenthesized . #t)
+ (stencil . ,ly:accidental-interface::print)
+ (Y-extent . ,accidental-interface::height)
+ (meta . ((class . Item)
+ (interfaces . (accidental-interface
+ inline-accidental-interface
+ font-interface))))))
(AccidentalPlacement
. (
- (direction . ,LEFT)
- (positioning-done . ,ly:accidental-placement::calc-positioning-done)
+ (direction . ,LEFT)
+ (positioning-done . ,ly:accidental-placement::calc-positioning-done)
- ;; this is quite small, but it is very ugly to have
- ;; accs closer to the previous note than to the next one.
- (right-padding . 0.15)
+ ;; this is quite small, but it is very ugly to have
+ ;; accs closer to the previous note than to the next one.
+ (right-padding . 0.15)
- ;; for horizontally stacked scripts.
- (script-priority . -100)
+ ;; for horizontally stacked scripts.
+ (script-priority . -100)
- (X-extent . ,ly:axis-group-interface::width)
- (meta . ((class . Item)
- (interfaces . (accidental-placement-interface))))))
+ (X-extent . ,ly:axis-group-interface::width)
+ (meta . ((class . Item)
+ (interfaces . (accidental-placement-interface))))))
(AccidentalSuggestion
. (
- (alteration . ,accidental-interface::calc-alteration)
- (direction . ,UP)
- (font-size . -2)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (outside-staff-priority . 0)
- (script-priority . 0)
- (self-alignment-X . ,CENTER)
- (side-axis . ,Y)
- (staff-padding . 0.25)
- (stencil . ,ly:accidental-interface::print)
- (X-extent . ,ly:accidental-interface::width)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::centered-on-x-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-extent . ,accidental-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Item)
- (interfaces . (accidental-interface
- accidental-suggestion-interface
- font-interface
- script-interface
- self-alignment-interface
- side-position-interface))))))
+ (alteration . ,accidental-interface::calc-alteration)
+ (direction . ,UP)
+ (font-size . -2)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (outside-staff-priority . 0)
+ (script-priority . 0)
+ (self-alignment-X . ,CENTER)
+ (side-axis . ,Y)
+ (staff-padding . 0.25)
+ (stencil . ,ly:accidental-interface::print)
+ (X-extent . ,ly:accidental-interface::width)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::centered-on-x-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-extent . ,accidental-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Item)
+ (interfaces . (accidental-interface
+ accidental-suggestion-interface
+ font-interface
+ script-interface
+ self-alignment-interface
+ side-position-interface))))))
(Ambitus
. (
- (axes . (,X ,Y))
- (break-align-symbol . ambitus)
- (break-visibility . ,begin-of-line-visible)
- (non-musical . #t)
- (space-alist . (
- (cue-end-clef . (extra-space . 0.5))
- (clef . (extra-space . 0.5))
- (cue-clef . (extra-space . 0.5))
- (key-signature . (extra-space . 0.0))
- (staff-bar . (extra-space . 0.0))
- (time-signature . (extra-space . 0.0))
- (first-note . (fixed-space . 0.0))))
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Item)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (ambitus-interface
- axis-group-interface
- break-aligned-interface))))))
+ (axes . (,X ,Y))
+ (break-align-symbol . ambitus)
+ (break-visibility . ,begin-of-line-visible)
+ (non-musical . #t)
+ (space-alist . (
+ (cue-end-clef . (extra-space . 0.5))
+ (clef . (extra-space . 0.5))
+ (cue-clef . (extra-space . 0.5))
+ (key-signature . (extra-space . 0.0))
+ (staff-bar . (extra-space . 0.0))
+ (time-signature . (extra-space . 0.0))
+ (first-note . (fixed-space . 0.0))))
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Item)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (ambitus-interface
+ axis-group-interface
+ break-aligned-interface))))))
(AmbitusAccidental
. (
- (direction . ,LEFT)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (padding . 0.5)
- (side-axis . ,X)
- (stencil . ,ly:accidental-interface::print)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . ,accidental-interface::height)
- (meta . ((class . Item)
- (interfaces . (accidental-interface
- break-aligned-interface
- font-interface
- side-position-interface))))))
+ (direction . ,LEFT)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (padding . 0.5)
+ (side-axis . ,X)
+ (stencil . ,ly:accidental-interface::print)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . ,accidental-interface::height)
+ (meta . ((class . Item)
+ (interfaces . (accidental-interface
+ break-aligned-interface
+ font-interface
+ side-position-interface))))))
(AmbitusLine
. (
- (gap . 0.35)
- (stencil . ,ambitus::print)
- (thickness . 2)
- (X-offset . ,ly:self-alignment-interface::centered-on-x-parent)
- (meta . ((class . Item)
- (interfaces . (ambitus-interface
- font-interface))))))
+ (gap . 0.35)
+ (stencil . ,ambitus::print)
+ (thickness . 2)
+ (X-offset . ,ly:self-alignment-interface::centered-on-x-parent)
+ (meta . ((class . Item)
+ (interfaces . (ambitus-interface
+ font-interface))))))
(AmbitusNoteHead
. (
- (duration-log . 2)
- (glyph-name . ,note-head::calc-glyph-name)
- (stencil . ,ly:note-head::print)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (ambitus-interface
- font-interface
- ledgered-interface
- note-head-interface
- rhythmic-head-interface
- staff-symbol-referencer-interface))))))
+ (duration-log . 2)
+ (glyph-name . ,note-head::calc-glyph-name)
+ (stencil . ,ly:note-head::print)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (ambitus-interface
+ font-interface
+ ledgered-interface
+ note-head-interface
+ rhythmic-head-interface
+ staff-symbol-referencer-interface))))))
(Arpeggio
. (
- (direction . ,LEFT)
- (padding . 0.5)
- (positions . ,ly:arpeggio::calc-positions)
- (protrusion . 0.4)
- (script-priority . 0)
- (side-axis . ,X)
- (staff-position . 0.0)
- (stencil . ,ly:arpeggio::print)
- (X-extent . ,ly:arpeggio::width)
- (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:arpeggio::pure-height))
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Item)
- (interfaces . (arpeggio-interface
- font-interface
- side-position-interface
- staff-symbol-referencer-interface))))))
+ (direction . ,LEFT)
+ (padding . 0.5)
+ (positions . ,ly:arpeggio::calc-positions)
+ (protrusion . 0.4)
+ (script-priority . 0)
+ (side-axis . ,X)
+ (staff-position . 0.0)
+ (stencil . ,ly:arpeggio::print)
+ (X-extent . ,ly:arpeggio::width)
+ (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:arpeggio::pure-height))
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Item)
+ (interfaces . (arpeggio-interface
+ font-interface
+ side-position-interface
+ staff-symbol-referencer-interface))))))
(BalloonTextItem
. (
- (annotation-balloon . #t)
- (annotation-line . #t)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (stencil . ,ly:balloon-interface::print)
- (text . ,(grob::calc-property-by-copy 'text))
- (X-offset . ,(grob::calc-property-by-copy 'X-offset))
- (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (balloon-interface
- font-interface
- text-interface))))))
+ (annotation-balloon . #t)
+ (annotation-line . #t)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (stencil . ,ly:balloon-interface::print)
+ (text . ,(grob::calc-property-by-copy 'text))
+ (X-offset . ,(grob::calc-property-by-copy 'X-offset))
+ (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (balloon-interface
+ font-interface
+ text-interface))))))
(BarLine
. (
- (allow-span-bar . #t)
- (bar-extent . ,ly:bar-line::calc-bar-extent)
- (break-align-anchor . ,ly:bar-line::calc-anchor)
- (break-align-symbol . staff-bar)
- (break-visibility . ,bar-line::calc-break-visibility)
- (extra-spacing-height . ,pure-from-neighbor-interface::account-for-span-bar)
- (gap . 0.4)
- (glyph . "|")
- (glyph-name . ,bar-line::calc-glyph-name)
-
- ;;
- ;; Ross. page 151 lists other values, we opt for a leaner look
- ;;
- ;; TODO:
- ;; kern should scale with line-thickness too.
- (kern . 3.0)
- (thin-kern . 3.0)
- (hair-thickness . 1.9)
- (thick-thickness . 6.0)
-
- (layer . 0)
- (non-musical . #t)
- (rounded . #f)
- (space-alist . (
- (time-signature . (extra-space . 0.75))
- (custos . (minimum-space . 2.0))
- (clef . (minimum-space . 1.0))
- (key-signature . (extra-space . 1.0))
- (key-cancellation . (extra-space . 1.0))
- (first-note . (fixed-space . 1.3))
- (next-note . (semi-fixed-space . 0.9))
- (right-edge . (extra-space . 0.0))))
- (stencil . ,ly:bar-line::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
+ (allow-span-bar . #t)
+ (bar-extent . ,ly:bar-line::calc-bar-extent)
+ (break-align-anchor . ,ly:bar-line::calc-anchor)
+ (break-align-symbol . staff-bar)
+ (break-visibility . ,bar-line::calc-break-visibility)
+ (extra-spacing-height . ,pure-from-neighbor-interface::account-for-span-bar)
+ (gap . 0.4)
+ (glyph . "|")
+ (glyph-name . ,bar-line::calc-glyph-name)
+
+ ;;
+ ;; Ross. page 151 lists other values, we opt for a leaner look
+ ;;
+ ;; TODO:
+ ;; kern should scale with line-thickness too.
+ (kern . 3.0)
+ (thin-kern . 3.0)
+ (hair-thickness . 1.9)
+ (thick-thickness . 6.0)
+
+ (layer . 0)
+ (non-musical . #t)
+ (rounded . #f)
+ (space-alist . (
+ (time-signature . (extra-space . 0.75))
+ (custos . (minimum-space . 2.0))
+ (clef . (minimum-space . 1.0))
+ (key-signature . (extra-space . 1.0))
+ (key-cancellation . (extra-space . 1.0))
+ (first-note . (fixed-space . 1.3))
+ (next-note . (semi-fixed-space . 0.9))
+ (right-edge . (extra-space . 0.0))))
+ (stencil . ,ly:bar-line::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (bar-line-interface
- break-aligned-interface
- font-interface
- pure-from-neighbor-interface))))))
+ (interfaces . (bar-line-interface
+ break-aligned-interface
+ font-interface
+ pure-from-neighbor-interface))))))
(BarNumber
. (
- (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
- ;; want the bar number before the clef at line start.
- (break-align-symbols . (left-edge staff-bar))
-
- (break-visibility . ,begin-of-line-visible)
- (direction . ,UP)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-family . roman)
- (font-size . -2)
- (non-musical . #t)
- ;; w/o padding, bars numbers are not positioned over the staff as
- ;; they are slightly to the left. so we add just a bit.
- (horizon-padding . 0.05)
- (outside-staff-priority . 100)
- (padding . 1.0)
- (self-alignment-X . ,RIGHT)
- (side-axis . ,Y)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:break-alignable-interface::self-align-callback))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta .
- ((class . Item)
- (interfaces . (break-alignable-interface
- font-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
+ ;; want the bar number before the clef at line start.
+ (break-align-symbols . (left-edge staff-bar))
+
+ (break-visibility . ,begin-of-line-visible)
+ (direction . ,UP)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-family . roman)
+ (font-size . -2)
+ (non-musical . #t)
+ ;; w/o padding, bars numbers are not positioned over the staff as
+ ;; they are slightly to the left. so we add just a bit.
+ (horizon-padding . 0.05)
+ (outside-staff-priority . 100)
+ (padding . 1.0)
+ (self-alignment-X . ,RIGHT)
+ (side-axis . ,Y)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:break-alignable-interface::self-align-callback))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta .
+ ((class . Item)
+ (interfaces . (break-alignable-interface
+ font-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(BassFigure
. (
- (stencil . ,ly:text-interface::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (bass-figure-interface
- font-interface
- rhythmic-grob-interface
- text-interface))))))
+ (stencil . ,ly:text-interface::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (bass-figure-interface
+ font-interface
+ rhythmic-grob-interface
+ text-interface))))))
(BassFigureAlignment
. (
- (axes . (,Y))
- (padding . 0.2)
- (positioning-done . ,ly:align-interface::align-to-minimum-distances)
- (stacking-dir . ,DOWN)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (align-interface
- axis-group-interface
- bass-figure-alignment-interface))))))
+ (axes . (,Y))
+ (padding . 0.2)
+ (positioning-done . ,ly:align-interface::align-to-minimum-distances)
+ (stacking-dir . ,DOWN)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (align-interface
+ axis-group-interface
+ bass-figure-alignment-interface))))))
(BassFigureAlignmentPositioning
. (
- (axes . (,Y))
- (direction . ,UP)
- (padding . 0.5)
- (side-axis . ,Y)
- (staff-padding . 1.0)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- side-position-interface))))))
+ (axes . (,Y))
+ (direction . ,UP)
+ (padding . 0.5)
+ (side-axis . ,Y)
+ (staff-padding . 1.0)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ side-position-interface))))))
(BassFigureBracket
. (
- (edge-height . (0.2 . 0.2))
- (stencil . ,ly:enclosing-bracket::print)
- (X-extent . ,ly:enclosing-bracket::width)
- (meta . ((class . Item)
- (interfaces . (enclosing-bracket-interface))))))
+ (edge-height . (0.2 . 0.2))
+ (stencil . ,ly:enclosing-bracket::print)
+ (X-extent . ,ly:enclosing-bracket::width)
+ (meta . ((class . Item)
+ (interfaces . (enclosing-bracket-interface))))))
(BassFigureContinuation
. (
- (stencil . ,ly:figured-bass-continuation::print)
- (Y-offset . ,ly:figured-bass-continuation::center-on-figures)
- (meta . ((class . Spanner)
- (interfaces . (figured-bass-continuation-interface))))))
+ (stencil . ,ly:figured-bass-continuation::print)
+ (Y-offset . ,ly:figured-bass-continuation::center-on-figures)
+ (meta . ((class . Spanner)
+ (interfaces . (figured-bass-continuation-interface))))))
(BassFigureLine
. (
- (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
- (axes . (,Y))
- (vertical-skylines . ,ly:axis-group-interface::calc-skylines)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface))))))
+ (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
+ (axes . (,Y))
+ (vertical-skylines . ,ly:axis-group-interface::calc-skylines)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface))))))
(Beam
. (
- ;; todo: clean this up a bit: the list is getting
- ;; rather long.
- (auto-knee-gap . 5.5)
- (beam-segments . ,ly:beam::calc-beam-segments)
- (beam-thickness . 0.48) ; in staff-space
-
- ;; We have some unreferenced problems here.
- ;;
- ;; If we shorten beamed stems less than normal stems (1 staff-space),
- ;; or high order less than 8th beams, patterns like
- ;; c''4 [c''8 c''] c''4 [c''16 c]
- ;; are ugly (different stem lengths).
- ;;
- ;; But if we shorten 16th beams as much as 8th beams, a single
- ;; forced 16th beam looks *very* short.
-
- ;; We choose to shorten 8th beams the same as single stems,
- ;; and high order beams less than 8th beams, so that all
- ;; isolated shortened beams look nice and a bit shortened,
- ;; sadly possibly breaking patterns with high order beams.
- (beamed-stem-shorten . (1.0 0.5 0.25))
-
- (beaming . ,ly:beam::calc-beaming)
- (clip-edges . #t)
- (collision-interfaces . (beam-interface
- clef-interface
- clef-modifier-interface
- flag-interface
- inline-accidental-interface
- key-signature-interface
- note-head-interface
- stem-interface
- time-signature-interface))
- (cross-staff . ,ly:beam::calc-cross-staff)
- (damping . 1)
- (details
+ ;; todo: clean this up a bit: the list is getting
+ ;; rather long.
+ (auto-knee-gap . 5.5)
+ (beam-segments . ,ly:beam::calc-beam-segments)
+ (beam-thickness . 0.48) ; in staff-space
+
+ ;; We have some unreferenced problems here.
+ ;;
+ ;; If we shorten beamed stems less than normal stems (1 staff-space),
+ ;; or high order less than 8th beams, patterns like
+ ;; c''4 [c''8 c''] c''4 [c''16 c]
+ ;; are ugly (different stem lengths).
+ ;;
+ ;; But if we shorten 16th beams as much as 8th beams, a single
+ ;; forced 16th beam looks *very* short.
+
+ ;; We choose to shorten 8th beams the same as single stems,
+ ;; and high order beams less than 8th beams, so that all
+ ;; isolated shortened beams look nice and a bit shortened,
+ ;; sadly possibly breaking patterns with high order beams.
+ (beamed-stem-shorten . (1.0 0.5 0.25))
+
+ (beaming . ,ly:beam::calc-beaming)
+ (clip-edges . #t)
+ (collision-interfaces . (beam-interface
+ clef-interface
+ clef-modifier-interface
+ flag-interface
+ inline-accidental-interface
+ key-signature-interface
+ note-head-interface
+ stem-interface
+ time-signature-interface))
+ (cross-staff . ,ly:beam::calc-cross-staff)
+ (damping . 1)
+ (details
.(
(secondary-beam-demerit . 10)
(stem-length-demerit-factor . 5)
(hint-direction-penalty . 20)
(musical-direction-factor . 400)
(ideal-slope-factor . 10)
- (collision-penalty . 500)
- (collision-padding . 0.35)
+ (collision-penalty . 500)
+ (collision-padding . 0.35)
(round-to-zero-slope . 0.02)))
- (direction . ,ly:beam::calc-direction)
-
- (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints)
- ;; only for debugging.
- (font-family . roman)
-
- (beam-gap . ,ly:beam::calc-beam-gap)
- (minimum-length . ,ly:beam::calc-minimum-length)
- (neutral-direction . ,DOWN)
- (positions . ,beam::place-broken-parts-individually)
- (springs-and-rods . ,ly:beam::calc-springs-and-rods)
- (X-positions . ,ly:beam::calc-x-positions)
+ (direction . ,ly:beam::calc-direction)
+
+ (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints)
+ ;; only for debugging.
+ (font-family . roman)
+
+ (beam-gap . ,ly:beam::calc-beam-gap)
+ (minimum-length . ,ly:beam::calc-minimum-length)
+ (neutral-direction . ,DOWN)
+ (positions . ,beam::place-broken-parts-individually)
+ (springs-and-rods . ,ly:beam::calc-springs-and-rods)
+ (X-positions . ,ly:beam::calc-x-positions)
(transparent . ,(grob::inherit-parent-property
X 'transparent))
- ;; this is a hack to set stem lengths, if positions is set.
- (quantized-positions . ,ly:beam::set-stem-lengths)
+ ;; this is a hack to set stem lengths, if positions is set.
+ (quantized-positions . ,ly:beam::set-stem-lengths)
- (shorten . ,ly:beam::calc-stem-shorten)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (stencil . ,ly:beam::print)
+ (shorten . ,ly:beam::calc-stem-shorten)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (stencil . ,ly:beam::print)
- (meta . ((class . Spanner)
- (object-callbacks . ((normal-stems . ,ly:beam::calc-normal-stems)))
- (interfaces . (beam-interface
- font-interface
- staff-symbol-referencer-interface
- unbreakable-spanner-interface))))))
+ (meta . ((class . Spanner)
+ (object-callbacks . ((normal-stems . ,ly:beam::calc-normal-stems)))
+ (interfaces . (beam-interface
+ font-interface
+ staff-symbol-referencer-interface
+ unbreakable-spanner-interface))))))
(BendAfter
. (
- (minimum-length . 0.5)
- (stencil . ,bend::print)
- (thickness . 2.0)
- (meta . ((class . Spanner)
- (interfaces . (bend-after-interface
- spanner-interface))))))
+ (minimum-length . 0.5)
+ (stencil . ,bend::print)
+ (thickness . 2.0)
+ (meta . ((class . Spanner)
+ (interfaces . (bend-after-interface
+ spanner-interface))))))
(BreakAlignGroup
. (
- (axes . (,X))
- (break-align-anchor . ,ly:break-aligned-interface::calc-average-anchor)
- (break-visibility . ,ly:break-aligned-interface::calc-break-visibility)
- (X-extent . ,ly:axis-group-interface::width)
- (meta . ((class . Item)
- (interfaces . (axis-group-interface
- break-aligned-interface))))))
+ (axes . (,X))
+ (break-align-anchor . ,ly:break-aligned-interface::calc-average-anchor)
+ (break-visibility . ,ly:break-aligned-interface::calc-break-visibility)
+ (X-extent . ,ly:axis-group-interface::width)
+ (meta . ((class . Item)
+ (interfaces . (axis-group-interface
+ break-aligned-interface))))))
(BreakAlignment
. (
- (axes . (,X))
- (break-align-orders . ;; end of line
- #((
- left-edge
- cue-end-clef
- ambitus
- breathing-sign
- clef
- cue-clef
- staff-bar
- key-cancellation
- key-signature
- time-signature
- custos)
-
- ;; unbroken
- (
- left-edge
- cue-end-clef
- ambitus
- breathing-sign
- clef
- cue-clef
- staff-bar
- key-cancellation
- key-signature
- time-signature
- custos)
-
- ;; begin of line
- (
- left-edge
- ambitus
- breathing-sign
- clef
- key-cancellation
- key-signature
- time-signature
- staff-bar
- cue-clef
- custos)))
- (non-musical . #t)
- (positioning-done . ,ly:break-alignment-interface::calc-positioning-done)
- (stacking-dir . 1)
- (X-extent . ,ly:axis-group-interface::width)
- (meta . ((class . Item)
- (interfaces . (axis-group-interface
- break-alignment-interface))))))
+ (axes . (,X))
+ (break-align-orders . ;; end of line
+ #((
+ left-edge
+ cue-end-clef
+ ambitus
+ breathing-sign
+ clef
+ cue-clef
+ staff-bar
+ key-cancellation
+ key-signature
+ time-signature
+ custos)
+
+ ;; unbroken
+ (
+ left-edge
+ cue-end-clef
+ ambitus
+ breathing-sign
+ clef
+ cue-clef
+ staff-bar
+ key-cancellation
+ key-signature
+ time-signature
+ custos)
+
+ ;; begin of line
+ (
+ left-edge
+ ambitus
+ breathing-sign
+ clef
+ key-cancellation
+ key-signature
+ time-signature
+ staff-bar
+ cue-clef
+ custos)))
+ (non-musical . #t)
+ (positioning-done . ,ly:break-alignment-interface::calc-positioning-done)
+ (stacking-dir . 1)
+ (X-extent . ,ly:axis-group-interface::width)
+ (meta . ((class . Item)
+ (interfaces . (axis-group-interface
+ break-alignment-interface))))))
(BreathingSign
. (
- (break-align-symbol . breathing-sign)
- (break-visibility . ,begin-of-line-invisible)
- (non-musical . #t)
- (space-alist . (
- (ambitus . (extra-space . 2.0))
- (custos . (minimum-space . 1.0))
- (key-signature . (minimum-space . 1.5))
- (time-signature . (minimum-space . 1.5))
- (staff-bar . (minimum-space . 1.5))
- (clef . (minimum-space . 2.0))
- (cue-clef . (minimum-space . 2.0))
- (cue-end-clef . (minimum-space . 2.0))
- (first-note . (fixed-space . 1.0)) ;huh?
- (right-edge . (extra-space . 0.1))))
- (stencil . ,ly:text-interface::print)
- (text . ,(make-musicglyph-markup "scripts.rcomma"))
- (Y-offset . ,ly:breathing-sign::offset-callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (break-aligned-interface
- breathing-sign-interface
- font-interface
- text-interface))))))
+ (break-align-symbol . breathing-sign)
+ (break-visibility . ,begin-of-line-invisible)
+ (non-musical . #t)
+ (space-alist . (
+ (ambitus . (extra-space . 2.0))
+ (custos . (minimum-space . 1.0))
+ (key-signature . (minimum-space . 1.5))
+ (time-signature . (minimum-space . 1.5))
+ (staff-bar . (minimum-space . 1.5))
+ (clef . (minimum-space . 2.0))
+ (cue-clef . (minimum-space . 2.0))
+ (cue-end-clef . (minimum-space . 2.0))
+ (first-note . (fixed-space . 1.0)) ;huh?
+ (right-edge . (extra-space . 0.1))))
+ (stencil . ,ly:text-interface::print)
+ (text . ,(make-musicglyph-markup "scripts.rcomma"))
+ (Y-offset . ,ly:breathing-sign::offset-callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (break-aligned-interface
+ breathing-sign-interface
+ font-interface
+ text-interface))))))
(ChordName
. (
- (after-line-breaking . ,ly:chord-name::after-line-breaking)
- (font-family . sans)
- (font-size . 1.5)
- (stencil . ,ly:text-interface::print)
- (extra-spacing-height . (0.2 . -0.2))
- (extra-spacing-width . (-0.5 . 0.5))
- (word-space . 0.0)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (chord-name-interface
- font-interface
- rhythmic-grob-interface
- text-interface))))))
+ (after-line-breaking . ,ly:chord-name::after-line-breaking)
+ (font-family . sans)
+ (font-size . 1.5)
+ (stencil . ,ly:text-interface::print)
+ (extra-spacing-height . (0.2 . -0.2))
+ (extra-spacing-width . (-0.5 . 0.5))
+ (word-space . 0.0)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (chord-name-interface
+ font-interface
+ rhythmic-grob-interface
+ text-interface))))))
(Clef
. (
- (avoid-slur . inside)
- (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-anchor-alignment . ,RIGHT)
- (break-align-symbol . clef)
- (break-visibility . ,begin-of-line-visible)
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
- (glyph-name . ,ly:clef::calc-glyph-name)
- (non-musical . #t)
- (space-alist . ((cue-clef . (extra-space . 2.0))
- (staff-bar . (extra-space . 0.7))
- (key-cancellation . (minimum-space . 3.5))
- (key-signature . (minimum-space . 3.5))
- (time-signature . (minimum-space . 4.2))
- (first-note . (minimum-fixed-space . 5.0))
- (next-note . (extra-space . 1.0))
- (right-edge . (extra-space . 0.5))))
- (stencil . ,ly:clef::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
+ (avoid-slur . inside)
+ (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-anchor-alignment . ,RIGHT)
+ (break-align-symbol . clef)
+ (break-visibility . ,begin-of-line-visible)
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
+ (glyph-name . ,ly:clef::calc-glyph-name)
+ (non-musical . #t)
+ (space-alist . ((cue-clef . (extra-space . 2.0))
+ (staff-bar . (extra-space . 0.7))
+ (key-cancellation . (minimum-space . 3.5))
+ (key-signature . (minimum-space . 3.5))
+ (time-signature . (minimum-space . 4.2))
+ (first-note . (minimum-fixed-space . 5.0))
+ (next-note . (extra-space . 1.0))
+ (right-edge . (extra-space . 0.5))))
+ (stencil . ,ly:clef::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- clef-interface
- font-interface
- pure-from-neighbor-interface
- staff-symbol-referencer-interface))))))
+ (interfaces . (break-aligned-interface
+ clef-interface
+ font-interface
+ pure-from-neighbor-interface
+ staff-symbol-referencer-interface))))))
(ClefModifier
. (
- (break-visibility . ,(grob::inherit-parent-property
+ (break-visibility . ,(grob::inherit-parent-property
X 'break-visibility))
- (font-shape . italic)
- (font-size . -4)
+ (font-shape . italic)
+ (font-size . -4)
(transparent . ,(grob::inherit-parent-property
X 'transparent))
(color . ,(grob::inherit-parent-property
X 'color))
- (self-alignment-X . ,CENTER)
- (staff-padding . 0.2)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::centered-on-x-parent)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (clef-modifier-interface
- font-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (self-alignment-X . ,CENTER)
+ (staff-padding . 0.2)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::centered-on-x-parent)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (clef-modifier-interface
+ font-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(ClusterSpanner
. (
- (cross-staff . ,ly:cluster::calc-cross-staff)
- (minimum-length . 0.0)
- (padding . 0.25)
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:cluster::print)
- (style . ramp)
- (meta . ((class . Spanner)
- (interfaces . (cluster-interface))))))
+ (cross-staff . ,ly:cluster::calc-cross-staff)
+ (minimum-length . 0.0)
+ (padding . 0.25)
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:cluster::print)
+ (style . ramp)
+ (meta . ((class . Spanner)
+ (interfaces . (cluster-interface))))))
(ClusterSpannerBeacon
. (
- (Y-extent . ,ly:cluster-beacon::height)
- (meta . ((class . Item)
- (interfaces . (cluster-beacon-interface
- rhythmic-grob-interface))))))
+ (Y-extent . ,ly:cluster-beacon::height)
+ (meta . ((class . Item)
+ (interfaces . (cluster-beacon-interface
+ rhythmic-grob-interface))))))
(CombineTextScript
. (
- (avoid-slur . outside)
- (baseline-skip . 2)
- (direction . ,UP)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-series . bold)
- (outside-staff-priority . 450)
- (padding . 0.5)
- (script-priority . 200)
- (side-axis . ,Y)
- (staff-padding . 0.5)
- ;; todo: add X self alignment?
- (stencil . ,ly:text-interface::print)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- side-position-interface
- text-interface
- text-script-interface))))))
+ (avoid-slur . outside)
+ (baseline-skip . 2)
+ (direction . ,UP)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-series . bold)
+ (outside-staff-priority . 450)
+ (padding . 0.5)
+ (script-priority . 200)
+ (side-axis . ,Y)
+ (staff-padding . 0.5)
+ ;; todo: add X self alignment?
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ side-position-interface
+ text-interface
+ text-script-interface))))))
(CueClef
. (
- (avoid-slur . inside)
- (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-symbol . cue-clef)
- (break-visibility . ,begin-of-line-visible)
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
- (font-size . -4)
- (glyph-name . ,ly:clef::calc-glyph-name)
- (non-musical . #t)
- (full-size-change . #t)
- (space-alist . ((staff-bar . (minimum-space . 2.7))
- (key-cancellation . (minimum-space . 3.5))
- (key-signature . (minimum-space . 3.5))
- (time-signature . (minimum-space . 4.2))
- (custos . (minimum-space . 0.0))
- (first-note . (minimum-fixed-space . 3.0))
- (next-note . (extra-space . 1.0))
- (right-edge . (extra-space . 0.5))))
- (stencil . ,ly:clef::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
+ (avoid-slur . inside)
+ (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-symbol . cue-clef)
+ (break-visibility . ,begin-of-line-visible)
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
+ (font-size . -4)
+ (glyph-name . ,ly:clef::calc-glyph-name)
+ (non-musical . #t)
+ (full-size-change . #t)
+ (space-alist . ((staff-bar . (minimum-space . 2.7))
+ (key-cancellation . (minimum-space . 3.5))
+ (key-signature . (minimum-space . 3.5))
+ (time-signature . (minimum-space . 4.2))
+ (custos . (minimum-space . 0.0))
+ (first-note . (minimum-fixed-space . 3.0))
+ (next-note . (extra-space . 1.0))
+ (right-edge . (extra-space . 0.5))))
+ (stencil . ,ly:clef::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- clef-interface
- font-interface
- pure-from-neighbor-interface
- staff-symbol-referencer-interface))))))
+ (interfaces . (break-aligned-interface
+ clef-interface
+ font-interface
+ pure-from-neighbor-interface
+ staff-symbol-referencer-interface))))))
(CueEndClef
. (
- (avoid-slur . inside)
- (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-symbol . cue-end-clef)
- (break-visibility . ,begin-of-line-invisible)
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
- (font-size . -4)
- (glyph-name . ,ly:clef::calc-glyph-name)
- (non-musical . #t)
- (full-size-change . #t)
- (space-alist . ((clef . (extra-space . 0.7))
- (cue-clef . (extra-space . 0.7))
- (staff-bar . (extra-space . 0.7))
- (key-cancellation . (minimum-space . 3.5))
- (key-signature . (minimum-space . 3.5))
- (time-signature . (minimum-space . 4.2))
- (first-note . (minimum-fixed-space . 5.0))
- (next-note . (extra-space . 1.0))
- (right-edge . (extra-space . 0.5))))
- (stencil . ,ly:clef::print)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
+ (avoid-slur . inside)
+ (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-symbol . cue-end-clef)
+ (break-visibility . ,begin-of-line-invisible)
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line)
+ (font-size . -4)
+ (glyph-name . ,ly:clef::calc-glyph-name)
+ (non-musical . #t)
+ (full-size-change . #t)
+ (space-alist . ((clef . (extra-space . 0.7))
+ (cue-clef . (extra-space . 0.7))
+ (staff-bar . (extra-space . 0.7))
+ (key-cancellation . (minimum-space . 3.5))
+ (key-signature . (minimum-space . 3.5))
+ (time-signature . (minimum-space . 4.2))
+ (first-note . (minimum-fixed-space . 5.0))
+ (next-note . (extra-space . 1.0))
+ (right-edge . (extra-space . 0.5))))
+ (stencil . ,ly:clef::print)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- clef-interface
- font-interface
- pure-from-neighbor-interface
- staff-symbol-referencer-interface))))))
+ (interfaces . (break-aligned-interface
+ clef-interface
+ font-interface
+ pure-from-neighbor-interface
+ staff-symbol-referencer-interface))))))
(Custos
. (
- (break-align-symbol . custos)
- (break-visibility . ,end-of-line-visible)
- (neutral-direction . ,DOWN)
- (non-musical . #t)
- (space-alist . (
- (first-note . (minimum-fixed-space . 0.0))
- (right-edge . (extra-space . 0.1))))
- (stencil . ,ly:custos::print)
- (style . vaticana)
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Item)
- (interfaces . (break-aligned-interface
- custos-interface
- font-interface
- staff-symbol-referencer-interface))))))
+ (break-align-symbol . custos)
+ (break-visibility . ,end-of-line-visible)
+ (neutral-direction . ,DOWN)
+ (non-musical . #t)
+ (space-alist . (
+ (first-note . (minimum-fixed-space . 0.0))
+ (right-edge . (extra-space . 0.1))))
+ (stencil . ,ly:custos::print)
+ (style . vaticana)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Item)
+ (interfaces . (break-aligned-interface
+ custos-interface
+ font-interface
+ staff-symbol-referencer-interface))))))
(DotColumn
. (
- (axes . (,X))
- (direction . ,RIGHT)
- (positioning-done . ,ly:dot-column::calc-positioning-done)
- (X-extent . ,ly:axis-group-interface::width)
- (meta . ((class . Item)
- (interfaces . (axis-group-interface
- dot-column-interface))))))
+ (axes . (,X))
+ (direction . ,RIGHT)
+ (positioning-done . ,ly:dot-column::calc-positioning-done)
+ (X-extent . ,ly:axis-group-interface::width)
+ (meta . ((class . Item)
+ (interfaces . (axis-group-interface
+ dot-column-interface))))))
(Dots
. (
- (avoid-slur . inside)
- (dot-count . ,dots::calc-dot-count)
- (staff-position . ,dots::calc-staff-position)
- (stencil . ,ly:dots::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (extra-spacing-height . (-0.5 . 0.5))
- (meta . ((class . Item)
- (interfaces . (dots-interface
- font-interface
- staff-symbol-referencer-interface))))))
+ (avoid-slur . inside)
+ (dot-count . ,dots::calc-dot-count)
+ (staff-position . ,dots::calc-staff-position)
+ (stencil . ,ly:dots::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (extra-spacing-height . (-0.5 . 0.5))
+ (meta . ((class . Item)
+ (interfaces . (dots-interface
+ font-interface
+ staff-symbol-referencer-interface))))))
(DoublePercentRepeat
. (
- (break-align-symbol . staff-bar)
- (break-visibility . ,begin-of-line-invisible)
- (dot-negative-kern . 0.75)
- (font-encoding . fetaMusic)
- (non-musical . #t)
- (slash-negative-kern . 1.6)
- (slope . 1.0)
- (stencil . ,ly:percent-repeat-item-interface::double-percent)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (thickness . 0.48)
- (meta . ((class . Item)
- (interfaces . (break-aligned-interface
- font-interface
- percent-repeat-interface
- percent-repeat-item-interface))))))
+ (break-align-symbol . staff-bar)
+ (break-visibility . ,begin-of-line-invisible)
+ (dot-negative-kern . 0.75)
+ (font-encoding . fetaMusic)
+ (non-musical . #t)
+ (slash-negative-kern . 1.6)
+ (slope . 1.0)
+ (stencil . ,ly:percent-repeat-item-interface::double-percent)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (thickness . 0.48)
+ (meta . ((class . Item)
+ (interfaces . (break-aligned-interface
+ font-interface
+ percent-repeat-interface
+ percent-repeat-item-interface))))))
(DoublePercentRepeatCounter
. (
- (direction . ,UP)
- (font-encoding . fetaText)
- (font-size . -2)
- (padding . 0.2)
- (self-alignment-X . ,CENTER)
- (side-axis . ,Y)
- (staff-padding . 0.25)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::centered-on-y-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- percent-repeat-interface
- percent-repeat-item-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (direction . ,UP)
+ (font-encoding . fetaText)
+ (font-size . -2)
+ (padding . 0.2)
+ (self-alignment-X . ,CENTER)
+ (side-axis . ,Y)
+ (staff-padding . 0.25)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::centered-on-y-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ percent-repeat-interface
+ percent-repeat-item-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(DoubleRepeatSlash
. (
- (dot-negative-kern . 0.75)
- (font-encoding . fetaMusic)
- (slash-negative-kern . 1.6)
- (slope . 1.0)
- (stencil . ,ly:percent-repeat-item-interface::beat-slash)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (thickness . 0.48)
- (meta . ((class . Item)
- (interfaces . (font-interface
- percent-repeat-interface
- percent-repeat-item-interface
- rhythmic-grob-interface))))))
+ (dot-negative-kern . 0.75)
+ (font-encoding . fetaMusic)
+ (slash-negative-kern . 1.6)
+ (slope . 1.0)
+ (stencil . ,ly:percent-repeat-item-interface::beat-slash)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (thickness . 0.48)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ percent-repeat-interface
+ percent-repeat-item-interface
+ rhythmic-grob-interface))))))
(DynamicLineSpanner
. (
- (axes . (,Y))
- (cross-staff . ,ly:side-position-interface::calc-cross-staff)
- (direction . ,DOWN)
- (minimum-space . 1.2)
- (outside-staff-priority . 250)
- (outside-staff-padding . 0.6)
- (padding . 0.6)
- (side-axis . ,Y)
- (slur-padding . 0.3)
- (staff-padding . 0.1)
- (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- dynamic-interface
- dynamic-line-spanner-interface
- side-position-interface))))))
+ (axes . (,Y))
+ (cross-staff . ,ly:side-position-interface::calc-cross-staff)
+ (direction . ,DOWN)
+ (minimum-space . 1.2)
+ (outside-staff-priority . 250)
+ (outside-staff-padding . 0.6)
+ (padding . 0.6)
+ (side-axis . ,Y)
+ (slur-padding . 0.3)
+ (staff-padding . 0.1)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ dynamic-interface
+ dynamic-line-spanner-interface
+ side-position-interface))))))
(DynamicText
. (
- ;; todo.
-
- (collision-bias . -2.0)
- (collision-padding . 0.5)
- (direction . ,ly:script-interface::calc-direction)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-encoding . fetaText)
- (font-series . bold)
- (font-shape . italic)
- (positioning-done . ,ly:script-interface::calc-positioning-done)
- (right-padding . 0.5)
- (self-alignment-X . ,CENTER)
- (self-alignment-Y . ,CENTER)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-offset . ,self-alignment-interface::y-aligned-on-self)
- (meta . ((class . Item)
- (interfaces . (dynamic-interface
- dynamic-text-interface
- font-interface
- script-interface
- self-alignment-interface
- text-interface))))))
+ ;; todo.
+
+ (collision-bias . -2.0)
+ (collision-padding . 0.5)
+ (direction . ,ly:script-interface::calc-direction)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-encoding . fetaText)
+ (font-series . bold)
+ (font-shape . italic)
+ (positioning-done . ,ly:script-interface::calc-positioning-done)
+ (right-padding . 0.5)
+ (self-alignment-X . ,CENTER)
+ (self-alignment-Y . ,CENTER)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-offset . ,self-alignment-interface::y-aligned-on-self)
+ (meta . ((class . Item)
+ (interfaces . (dynamic-interface
+ dynamic-text-interface
+ font-interface
+ script-interface
+ self-alignment-interface
+ text-interface))))))
(DynamicTextSpanner
. (
- (before-line-breaking . ,dynamic-text-spanner::before-line-breaking)
- (bound-details . ((right . ((attach-dir . ,LEFT)
- (Y . 0)
- (padding . 0.75)
- ))
- (right-broken . ((attach-dir . ,RIGHT)
- (padding . 0.0)
- ))
-
- (left . ((attach-dir . ,LEFT)
- (Y . 0)
- (stencil-offset . (-0.75 . -0.5))
- (padding . 0.75)
- ))
- (left-broken . ((attach-dir . ,RIGHT)
- ))
- ))
- (dash-fraction . 0.2)
- (dash-period . 3.0)
-
- ;; rather ugh with NCSB
- ;; (font-series . bold)
- (font-shape . italic)
-
- ;; need to blend with dynamic texts.
- (font-size . 1)
-
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info-and-text)
-
- (minimum-length . 2.0)
- ;; make sure the spanner doesn't get too close to notes
- (minimum-Y-extent . (-1 . 1))
-
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (skyline-horizontal-padding . 0.2)
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:line-spanner::print)
- (style . dashed-line)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (meta . ((class . Spanner)
- (interfaces . (dynamic-interface
- dynamic-text-spanner-interface
- font-interface
- line-interface
- line-spanner-interface
- spanner-interface
- text-interface))))))
+ (before-line-breaking . ,dynamic-text-spanner::before-line-breaking)
+ (bound-details . ((right . ((attach-dir . ,LEFT)
+ (Y . 0)
+ (padding . 0.75)
+ ))
+ (right-broken . ((attach-dir . ,RIGHT)
+ (padding . 0.0)
+ ))
+
+ (left . ((attach-dir . ,LEFT)
+ (Y . 0)
+ (stencil-offset . (-0.75 . -0.5))
+ (padding . 0.75)
+ ))
+ (left-broken . ((attach-dir . ,RIGHT)
+ ))
+ ))
+ (dash-fraction . 0.2)
+ (dash-period . 3.0)
+
+ ;; rather ugh with NCSB
+ ;; (font-series . bold)
+ (font-shape . italic)
+
+ ;; need to blend with dynamic texts.
+ (font-size . 1)
+
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info-and-text)
+
+ (minimum-length . 2.0)
+ ;; make sure the spanner doesn't get too close to notes
+ (minimum-Y-extent . (-1 . 1))
+
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (skyline-horizontal-padding . 0.2)
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:line-spanner::print)
+ (style . dashed-line)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (meta . ((class . Spanner)
+ (interfaces . (dynamic-interface
+ dynamic-text-spanner-interface
+ font-interface
+ line-interface
+ line-spanner-interface
+ spanner-interface
+ text-interface))))))
(Episema
. (
- (bound-details . ((left . ((Y . 0)
- (padding . 0)
- (attach-dir . ,LEFT)
- ))
- (right . ((Y . 0)
- (padding . 0)
- (attach-dir . ,RIGHT)
- ))
- ))
- (direction . ,UP)
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
- (quantize-position . #t)
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (side-axis . ,Y)
- (stencil . ,ly:line-spanner::print)
- (style . line)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (interfaces . (episema-interface
- font-interface
- line-interface
- line-spanner-interface
- side-position-interface))))))
+ (bound-details . ((left . ((Y . 0)
+ (padding . 0)
+ (attach-dir . ,LEFT)
+ ))
+ (right . ((Y . 0)
+ (padding . 0)
+ (attach-dir . ,RIGHT)
+ ))
+ ))
+ (direction . ,UP)
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
+ (quantize-position . #t)
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (side-axis . ,Y)
+ (stencil . ,ly:line-spanner::print)
+ (style . line)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (interfaces . (episema-interface
+ font-interface
+ line-interface
+ line-spanner-interface
+ side-position-interface))))))
(Fingering
. (
- ;; sync with TextScript (?)
- (add-stem-support . ,only-if-beamed)
- (avoid-slur . around)
- (cross-staff . ,script-or-side-position-cross-staff)
- (direction . ,ly:script-interface::calc-direction)
- (font-encoding . fetaText)
- (font-size . -5) ; don't overlap when next to heads.
- (padding . 0.5)
- (positioning-done . ,ly:script-interface::calc-positioning-done)
- (script-priority . 100)
- (self-alignment-X . ,CENTER)
- (self-alignment-Y . ,CENTER)
- (slur-padding . 0.2)
- (staff-padding . 0.5)
- (stencil . ,ly:text-interface::print)
- (text . ,fingering::calc-text)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (finger-interface
- font-interface
- self-alignment-interface
- side-position-interface
- text-interface
- text-script-interface))))))
+ ;; sync with TextScript (?)
+ (add-stem-support . ,only-if-beamed)
+ (avoid-slur . around)
+ (cross-staff . ,script-or-side-position-cross-staff)
+ (direction . ,ly:script-interface::calc-direction)
+ (font-encoding . fetaText)
+ (font-size . -5) ; don't overlap when next to heads.
+ (padding . 0.5)
+ (positioning-done . ,ly:script-interface::calc-positioning-done)
+ (script-priority . 100)
+ (self-alignment-X . ,CENTER)
+ (self-alignment-Y . ,CENTER)
+ (slur-padding . 0.2)
+ (staff-padding . 0.5)
+ (stencil . ,ly:text-interface::print)
+ (text . ,fingering::calc-text)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (finger-interface
+ font-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface
+ text-script-interface))))))
(FingeringColumn
. (
- (padding . 0.2)
- (positioning-done . ,ly:fingering-column::calc-positioning-done)
- (snap-radius . 0.3)
- (meta . ((class . Item)
- (interfaces . (fingering-column-interface))))))
+ (padding . 0.2)
+ (positioning-done . ,ly:fingering-column::calc-positioning-done)
+ (snap-radius . 0.3)
+ (meta . ((class . Item)
+ (interfaces . (fingering-column-interface))))))
(Flag
. (
- (glyph-name . ,ly:flag::glyph-name)
- (stencil . ,ly:flag::print)
+ (glyph-name . ,ly:flag::glyph-name)
+ (stencil . ,ly:flag::print)
(transparent . ,(grob::inherit-parent-property
X 'transparent))
(color . ,(grob::inherit-parent-property
X 'color))
- (X-extent . ,ly:flag::width)
- (X-offset . ,ly:flag::calc-x-offset)
- (Y-offset . ,(ly:make-unpure-pure-container ly:flag::calc-y-offset ly:flag::pure-calc-y-offset))
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (meta . ((class . Item)
- (interfaces . (flag-interface
+ (X-extent . ,ly:flag::width)
+ (X-offset . ,ly:flag::calc-x-offset)
+ (Y-offset . ,(ly:make-unpure-pure-container ly:flag::calc-y-offset ly:flag::pure-calc-y-offset))
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (flag-interface
font-interface))))))
(FootnoteItem
. (
- (annotation-balloon . #f)
- (annotation-line . #t)
- (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered))
- (break-visibility . ,(grob::inherit-parent-property
+ (annotation-balloon . #f)
+ (annotation-line . #t)
+ (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered))
+ (break-visibility . ,(grob::inherit-parent-property
X 'break-visibility))
- (footnote . #t)
- (footnote-text . ,(grob::calc-property-by-copy 'footnote-text))
- (stencil . ,ly:balloon-interface::print)
- (text . ,(grob::calc-property-by-copy 'text))
- (X-extent . #f)
- (Y-extent . #f)
- (X-offset . ,(grob::calc-property-by-copy 'X-offset))
- (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
- (meta . ((class . Item)
- (interfaces . (balloon-interface
- footnote-interface
- font-interface
- text-interface))))))
+ (footnote . #t)
+ (footnote-text . ,(grob::calc-property-by-copy 'footnote-text))
+ (stencil . ,ly:balloon-interface::print)
+ (text . ,(grob::calc-property-by-copy 'text))
+ (X-extent . #f)
+ (Y-extent . #f)
+ (X-offset . ,(grob::calc-property-by-copy 'X-offset))
+ (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
+ (meta . ((class . Item)
+ (interfaces . (balloon-interface
+ footnote-interface
+ font-interface
+ text-interface))))))
(FootnoteSpanner
. (
- (annotation-balloon . #f)
- (annotation-line . #t)
- (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered))
- (footnote . #t)
- (footnote-text . ,(grob::calc-property-by-copy 'footnote-text))
- (spanner-placement . ,LEFT)
- (stencil . ,ly:balloon-interface::print-spanner)
- (text . ,(grob::calc-property-by-copy 'text))
- (X-extent . #f)
- (Y-extent . #f)
- (X-offset . ,(grob::calc-property-by-copy 'X-offset))
- (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
- (meta . ((class . Spanner)
- (interfaces . (balloon-interface
+ (annotation-balloon . #f)
+ (annotation-line . #t)
+ (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered))
+ (footnote . #t)
+ (footnote-text . ,(grob::calc-property-by-copy 'footnote-text))
+ (spanner-placement . ,LEFT)
+ (stencil . ,ly:balloon-interface::print-spanner)
+ (text . ,(grob::calc-property-by-copy 'text))
+ (X-extent . #f)
+ (Y-extent . #f)
+ (X-offset . ,(grob::calc-property-by-copy 'X-offset))
+ (Y-offset . ,(grob::calc-property-by-copy 'Y-offset))
+ (meta . ((class . Spanner)
+ (interfaces . (balloon-interface
footnote-interface
- footnote-spanner-interface
- font-interface
- text-interface))))))
+ footnote-spanner-interface
+ font-interface
+ text-interface))))))
(FretBoard
. (
- (after-line-breaking . ,ly:chord-name::after-line-breaking)
- (fret-diagram-details . ((finger-code . below-string)))
- (stencil . ,fret-board::calc-stencil)
- (extra-spacing-height . (0.2 . -0.2))
- (extra-spacing-width . (-0.5 . 0.5))
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (chord-name-interface
- font-interface
- fret-diagram-interface
- rhythmic-grob-interface))))))
+ (after-line-breaking . ,ly:chord-name::after-line-breaking)
+ (fret-diagram-details . ((finger-code . below-string)))
+ (stencil . ,fret-board::calc-stencil)
+ (extra-spacing-height . (0.2 . -0.2))
+ (extra-spacing-width . (-0.5 . 0.5))
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (chord-name-interface
+ font-interface
+ fret-diagram-interface
+ rhythmic-grob-interface))))))
(Glissando
. (
- (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
- (bound-details . ((right . ((attach-dir . ,LEFT)
- (end-on-accidental . #t)
- (padding . 0.5)
- ))
- (left . ((attach-dir . ,RIGHT)
- (padding . 0.5)
- ))
- ))
- (cross-staff . ,ly:line-spanner::calc-cross-staff)
- (gap . 0.5)
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
- (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints)
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (simple-Y . #t)
- (stencil . ,ly:line-spanner::print)
- (style . line)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (X-extent . #f)
- (Y-extent . #f)
- (zigzag-width . 0.75)
- (meta . ((class . Spanner)
- (interfaces . (glissando-interface
- line-interface
- line-spanner-interface
- unbreakable-spanner-interface))))))
+ (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
+ (bound-details . ((right . ((attach-dir . ,LEFT)
+ (end-on-accidental . #t)
+ (padding . 0.5)
+ ))
+ (left . ((attach-dir . ,RIGHT)
+ (padding . 0.5)
+ ))
+ ))
+ (cross-staff . ,ly:line-spanner::calc-cross-staff)
+ (gap . 0.5)
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
+ (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints)
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (simple-Y . #t)
+ (stencil . ,ly:line-spanner::print)
+ (style . line)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (zigzag-width . 0.75)
+ (meta . ((class . Spanner)
+ (interfaces . (glissando-interface
+ line-interface
+ line-spanner-interface
+ unbreakable-spanner-interface))))))
(GraceSpacing
. (
- (common-shortest-duration . ,grace-spacing::calc-shortest-duration)
- (shortest-duration-space . 1.6)
- (spacing-increment . 0.8)
- (meta . ((class . Spanner)
- (interfaces . (grace-spacing-interface
- spacing-options-interface
- spanner-interface))))))
+ (common-shortest-duration . ,grace-spacing::calc-shortest-duration)
+ (shortest-duration-space . 1.6)
+ (spacing-increment . 0.8)
+ (meta . ((class . Spanner)
+ (interfaces . (grace-spacing-interface
+ spacing-options-interface
+ spanner-interface))))))
(GridLine
. (
- (layer . 0)
- (self-alignment-X . ,CENTER)
- (stencil . ,ly:grid-line-interface::print)
- (X-extent . ,ly:grid-line-interface::width)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::centered-on-x-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (meta . ((class . Item)
- (interfaces . (grid-line-interface
- self-alignment-interface))))))
+ (layer . 0)
+ (self-alignment-X . ,CENTER)
+ (stencil . ,ly:grid-line-interface::print)
+ (X-extent . ,ly:grid-line-interface::width)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::centered-on-x-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (meta . ((class . Item)
+ (interfaces . (grid-line-interface
+ self-alignment-interface))))))
(GridPoint
. (
- (X-extent . (0 . 0))
- (Y-extent . (0 . 0))
- (meta . ((class . Item)
- (interfaces . (grid-point-interface))))))
+ (X-extent . (0 . 0))
+ (Y-extent . (0 . 0))
+ (meta . ((class . Item)
+ (interfaces . (grid-point-interface))))))
(Hairpin
. (
- (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
- (bound-padding . 1.0)
- (broken-bound-padding . ,ly:hairpin::broken-bound-padding)
- (circled-tip . #f)
- (grow-direction . ,hairpin::calc-grow-direction)
- (height . 0.6666)
- (minimum-length . 2.0)
- (self-alignment-Y . ,CENTER)
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:hairpin::print)
- (thickness . 1.0)
- (to-barline . #t)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:hairpin::pure-height))
- (Y-offset . ,self-alignment-interface::y-aligned-on-self)
- (meta . ((class . Spanner)
- (interfaces . (dynamic-interface
- hairpin-interface
- line-interface
- self-alignment-interface
- spanner-interface))))))
+ (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
+ (bound-padding . 1.0)
+ (broken-bound-padding . ,ly:hairpin::broken-bound-padding)
+ (circled-tip . #f)
+ (grow-direction . ,hairpin::calc-grow-direction)
+ (height . 0.6666)
+ (minimum-length . 2.0)
+ (self-alignment-Y . ,CENTER)
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:hairpin::print)
+ (thickness . 1.0)
+ (to-barline . #t)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:hairpin::pure-height))
+ (Y-offset . ,self-alignment-interface::y-aligned-on-self)
+ (meta . ((class . Spanner)
+ (interfaces . (dynamic-interface
+ hairpin-interface
+ line-interface
+ self-alignment-interface
+ spanner-interface))))))
(HorizontalBracket
. (
- (bracket-flare . (0.5 . 0.5))
- (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
- (direction . ,DOWN)
- (padding . 0.2)
- (side-axis . ,Y)
- (staff-padding . 0.2)
- (stencil . ,ly:horizontal-bracket::print)
- (thickness . 1.0)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (interfaces . (horizontal-bracket-interface
- line-interface
- side-position-interface
- spanner-interface))))))
+ (bracket-flare . (0.5 . 0.5))
+ (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
+ (direction . ,DOWN)
+ (padding . 0.2)
+ (side-axis . ,Y)
+ (staff-padding . 0.2)
+ (stencil . ,ly:horizontal-bracket::print)
+ (thickness . 1.0)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (interfaces . (horizontal-bracket-interface
+ line-interface
+ side-position-interface
+ spanner-interface))))))
(InstrumentName
. (
- (direction . ,LEFT)
- (padding . 0.3)
- (self-alignment-X . ,CENTER)
- (self-alignment-Y . ,CENTER)
- (stencil . ,system-start-text::print)
- (X-offset . ,system-start-text::calc-x-offset)
- (Y-offset . ,system-start-text::calc-y-offset)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- self-alignment-interface
- side-position-interface
- system-start-text-interface))))))
+ (direction . ,LEFT)
+ (padding . 0.3)
+ (self-alignment-X . ,CENTER)
+ (self-alignment-Y . ,CENTER)
+ (stencil . ,system-start-text::print)
+ (X-offset . ,system-start-text::calc-x-offset)
+ (Y-offset . ,system-start-text::calc-y-offset)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ self-alignment-interface
+ side-position-interface
+ system-start-text-interface))))))
(InstrumentSwitch
. (
- (direction . ,UP)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (outside-staff-priority . 500)
- (padding . 0.5)
- (self-alignment-X . ,LEFT)
- (side-axis . ,Y)
- (staff-padding . 0.5)
- (stencil . ,ly:text-interface::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Item)
- (interfaces . (font-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (direction . ,UP)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (outside-staff-priority . 500)
+ (padding . 0.5)
+ (self-alignment-X . ,LEFT)
+ (side-axis . ,Y)
+ (staff-padding . 0.5)
+ (stencil . ,ly:text-interface::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(KeyCancellation
. (
- (break-align-symbol . key-cancellation)
- (break-visibility . ,begin-of-line-invisible)
- (glyph-name-alist . ,cancellation-glyph-name-alist)
- (non-musical . #t)
- (flat-positions . (2 3 4 2 1 2 1))
- (sharp-positions . (4 5 4 2 3 2 3))
- (space-alist . (
- (time-signature . (extra-space . 1.25))
- (staff-bar . (extra-space . 0.6))
- (key-signature . (extra-space . 0.5))
- (cue-clef . (extra-space . 0.5))
- (right-edge . (extra-space . 0.5))
- (first-note . (fixed-space . 2.5))))
- (stencil . ,ly:key-signature-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (extra-spacing-width . (0.0 . 1.0))
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Item)
+ (break-align-symbol . key-cancellation)
+ (break-visibility . ,begin-of-line-invisible)
+ (glyph-name-alist . ,cancellation-glyph-name-alist)
+ (non-musical . #t)
+ (flat-positions . (2 3 4 2 1 2 1))
+ (sharp-positions . (4 5 4 2 3 2 3))
+ (space-alist . (
+ (time-signature . (extra-space . 1.25))
+ (staff-bar . (extra-space . 0.6))
+ (key-signature . (extra-space . 0.5))
+ (cue-clef . (extra-space . 0.5))
+ (right-edge . (extra-space . 0.5))
+ (first-note . (fixed-space . 2.5))))
+ (stencil . ,ly:key-signature-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (extra-spacing-width . (0.0 . 1.0))
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- font-interface
- key-cancellation-interface
- key-signature-interface
- pure-from-neighbor-interface
- staff-symbol-referencer-interface))))))
+ (interfaces . (break-aligned-interface
+ font-interface
+ key-cancellation-interface
+ key-signature-interface
+ pure-from-neighbor-interface
+ staff-symbol-referencer-interface))))))
(KeySignature
. (
- (avoid-slur . inside)
- (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-anchor-alignment . ,RIGHT)
- (break-align-symbol . key-signature)
- (break-visibility . ,begin-of-line-visible)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (non-musical . #t)
- (flat-positions . (2 3 4 2 1 2 1))
- (sharp-positions . (4 5 4 2 3 2 3))
- (space-alist . (
- (time-signature . (extra-space . 1.15))
- (staff-bar . (extra-space . 1.1))
- (cue-clef . (extra-space . 0.5))
- (right-edge . (extra-space . 0.5))
- (first-note . (fixed-space . 2.5))))
- (stencil . ,ly:key-signature-interface::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (extra-spacing-width . (0.0 . 1.0))
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Item)
+ (avoid-slur . inside)
+ (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-anchor-alignment . ,RIGHT)
+ (break-align-symbol . key-signature)
+ (break-visibility . ,begin-of-line-visible)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (non-musical . #t)
+ (flat-positions . (2 3 4 2 1 2 1))
+ (sharp-positions . (4 5 4 2 3 2 3))
+ (space-alist . (
+ (time-signature . (extra-space . 1.15))
+ (staff-bar . (extra-space . 1.1))
+ (cue-clef . (extra-space . 0.5))
+ (right-edge . (extra-space . 0.5))
+ (first-note . (fixed-space . 2.5))))
+ (stencil . ,ly:key-signature-interface::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (extra-spacing-width . (0.0 . 1.0))
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- font-interface
- key-signature-interface
- pure-from-neighbor-interface
- staff-symbol-referencer-interface))))))
+ (interfaces . (break-aligned-interface
+ font-interface
+ key-signature-interface
+ pure-from-neighbor-interface
+ staff-symbol-referencer-interface))))))
(KievanLigature
. (
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:kievan-ligature::print)
- (padding . 0.5)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- kievan-ligature-interface))))))
-
- (LaissezVibrerTie
- . (
- (control-points . ,ly:semi-tie::calc-control-points)
- (cross-staff . ,semi-tie::calc-cross-staff)
- (details . ((ratio . 0.333)
- (height-limit . 1.0)))
- (direction . ,ly:tie::calc-direction)
- (head-direction . ,LEFT)
- (stencil . ,laissez-vibrer::print)
- (thickness . 1.0)
- (extra-spacing-height . (-0.5 . 0.5))
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (semi-tie-interface))))))
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:kievan-ligature::print)
+ (padding . 0.5)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ kievan-ligature-interface))))))
+
+ (LaissezVibrerTie
+ . (
+ (control-points . ,ly:semi-tie::calc-control-points)
+ (cross-staff . ,semi-tie::calc-cross-staff)
+ (details . ((ratio . 0.333)
+ (height-limit . 1.0)))
+ (direction . ,ly:tie::calc-direction)
+ (head-direction . ,LEFT)
+ (stencil . ,laissez-vibrer::print)
+ (thickness . 1.0)
+ (extra-spacing-height . (-0.5 . 0.5))
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (semi-tie-interface))))))
(LaissezVibrerTieColumn
. (
- (head-direction . ,ly:semi-tie-column::calc-head-direction)
- (positioning-done . ,ly:semi-tie-column::calc-positioning-done)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Item)
- (interfaces . (semi-tie-column-interface))))))
+ (head-direction . ,ly:semi-tie-column::calc-head-direction)
+ (positioning-done . ,ly:semi-tie-column::calc-positioning-done)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Item)
+ (interfaces . (semi-tie-column-interface))))))
(LedgerLineSpanner
. (
- (layer . 0)
- (length-fraction . 0.25)
- (minimum-length-fraction . 0.25)
- (springs-and-rods . ,ly:ledger-line-spanner::set-spacing-rods)
- (stencil . ,ly:ledger-line-spanner::print)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (ledger-line-spanner-interface))))))
+ (layer . 0)
+ (length-fraction . 0.25)
+ (minimum-length-fraction . 0.25)
+ (springs-and-rods . ,ly:ledger-line-spanner::set-spacing-rods)
+ (stencil . ,ly:ledger-line-spanner::print)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (ledger-line-spanner-interface))))))
(LeftEdge
. (
- (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-symbol . left-edge)
- (break-visibility . ,center-invisible)
- (non-musical . #t)
- (extra-spacing-height . (+inf.0 . -inf.0))
- (space-alist . (
- (ambitus . (extra-space . 2.0))
- (breathing-sign . (minimum-space . 0.0))
- (cue-end-clef . (extra-space . 0.8))
- (clef . (extra-space . 0.8))
- (cue-clef . (extra-space . 0.8))
- (staff-bar . (extra-space . 0.0))
- (key-cancellation . (extra-space . 0.0))
- (key-signature . (extra-space . 0.8))
- (time-signature . (extra-space . 1.0))
- (custos . (extra-space . 0.0))
- (first-note . (fixed-space . 2.0))
- (right-edge . (extra-space . 0.0))
- ))
- (X-extent . (0 . 0))
- (meta . ((class . Item)
- (interfaces . (break-aligned-interface))))))
+ (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-symbol . left-edge)
+ (break-visibility . ,center-invisible)
+ (non-musical . #t)
+ (extra-spacing-height . (+inf.0 . -inf.0))
+ (space-alist . (
+ (ambitus . (extra-space . 2.0))
+ (breathing-sign . (minimum-space . 0.0))
+ (cue-end-clef . (extra-space . 0.8))
+ (clef . (extra-space . 0.8))
+ (cue-clef . (extra-space . 0.8))
+ (staff-bar . (extra-space . 0.0))
+ (key-cancellation . (extra-space . 0.0))
+ (key-signature . (extra-space . 0.8))
+ (time-signature . (extra-space . 1.0))
+ (custos . (extra-space . 0.0))
+ (first-note . (fixed-space . 2.0))
+ (right-edge . (extra-space . 0.0))
+ ))
+ (X-extent . (0 . 0))
+ (meta . ((class . Item)
+ (interfaces . (break-aligned-interface))))))
(LigatureBracket
. (
- ;; ugh. A ligature bracket is totally different from
- ;; a tuplet bracket.
-
- (bracket-visibility . #t)
- (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
- (direction . ,UP)
- (edge-height . (0.7 . 0.7))
- (padding . 2.0)
- (positions . ,ly:tuplet-bracket::calc-positions)
- (shorten-pair . (-0.2 . -0.2))
- (staff-padding . 0.25)
- (stencil . ,ly:tuplet-bracket::print)
- (thickness . 1.6)
- (X-positions . ,ly:tuplet-bracket::calc-x-positions)
- (meta . ((class . Spanner)
- (interfaces . (line-interface
- tuplet-bracket-interface))))))
+ ;; ugh. A ligature bracket is totally different from
+ ;; a tuplet bracket.
+
+ (bracket-visibility . #t)
+ (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
+ (direction . ,UP)
+ (edge-height . (0.7 . 0.7))
+ (padding . 2.0)
+ (positions . ,ly:tuplet-bracket::calc-positions)
+ (shorten-pair . (-0.2 . -0.2))
+ (staff-padding . 0.25)
+ (stencil . ,ly:tuplet-bracket::print)
+ (thickness . 1.6)
+ (X-positions . ,ly:tuplet-bracket::calc-x-positions)
+ (meta . ((class . Spanner)
+ (interfaces . (line-interface
+ tuplet-bracket-interface))))))
(LyricExtender
. (
- (minimum-length . 1.5)
- (stencil . ,ly:lyric-extender::print)
- (thickness . 0.8) ; line-thickness
- (Y-extent . (0 . 0))
- (meta . ((class . Spanner)
- (interfaces . (lyric-extender-interface
- lyric-interface))))))
+ (minimum-length . 1.5)
+ (stencil . ,ly:lyric-extender::print)
+ (thickness . 0.8) ; line-thickness
+ (Y-extent . (0 . 0))
+ (meta . ((class . Spanner)
+ (interfaces . (lyric-extender-interface
+ lyric-interface))))))
(LyricHyphen
. (
- (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
- (dash-period . 10.0)
- (height . 0.42)
- (length . 0.66)
- (minimum-distance . 0.1)
- (minimum-length . 0.3)
- (padding . 0.07)
- (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods)
- (stencil . ,ly:lyric-hyphen::print)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (thickness . 1.3)
- (Y-extent . (0 . 0))
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- lyric-hyphen-interface
- lyric-interface
- spanner-interface))))))
+ (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
+ (dash-period . 10.0)
+ (height . 0.42)
+ (length . 0.66)
+ (minimum-distance . 0.1)
+ (minimum-length . 0.3)
+ (padding . 0.07)
+ (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods)
+ (stencil . ,ly:lyric-hyphen::print)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (thickness . 1.3)
+ (Y-extent . (0 . 0))
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ lyric-hyphen-interface
+ lyric-interface
+ spanner-interface))))))
(LyricSpace
. (
- (minimum-distance . 0.45)
- (padding . 0.0)
- (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (lyric-hyphen-interface
- spanner-interface))))))
+ (minimum-distance . 0.45)
+ (padding . 0.0)
+ (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (lyric-hyphen-interface
+ spanner-interface))))))
(LyricText
. (
- (extra-spacing-width . (0.0 . 0.0))
- ;; Recede in height for purposes of note spacing,
- ;; so notes in melismata can be freely spaced above lyrics
- (extra-spacing-height . (0.2 . -0.2))
- (font-series . medium)
- (font-size . 1.0)
- (self-alignment-X . ,CENTER)
- (stencil . ,lyric-text::print)
- (text . ,(grob::calc-property-by-copy 'text))
- (word-space . 0.6)
- (skyline-horizontal-padding . 0.1)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (X-offset . ,ly:self-alignment-interface::aligned-on-x-parent)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- lyric-syllable-interface
- rhythmic-grob-interface
- self-alignment-interface
- text-interface))))))
+ (extra-spacing-width . (0.0 . 0.0))
+ ;; Recede in height for purposes of note spacing,
+ ;; so notes in melismata can be freely spaced above lyrics
+ (extra-spacing-height . (0.2 . -0.2))
+ (font-series . medium)
+ (font-size . 1.0)
+ (self-alignment-X . ,CENTER)
+ (stencil . ,lyric-text::print)
+ (text . ,(grob::calc-property-by-copy 'text))
+ (word-space . 0.6)
+ (skyline-horizontal-padding . 0.1)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::aligned-on-x-parent)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ lyric-syllable-interface
+ rhythmic-grob-interface
+ self-alignment-interface
+ text-interface))))))
(MeasureCounter
. (
(outside-staff-padding . 0.5)
(outside-staff-priority . 750)
(self-alignment-X . ,CENTER)
- (side-axis . ,Y)
+ (side-axis . ,Y)
(staff-padding . 0.5)
(stencil . ,measure-counter-stencil)
(meta . ((class . Spanner)
(interfaces . (font-interface
measure-counter-interface
self-alignment-interface
- side-position-interface
+ side-position-interface
text-interface))))))
(MeasureGrouping
. (
- (direction . ,UP)
- (height . 2.0)
- (padding . 2)
- (side-axis . ,Y)
- (staff-padding . 3)
- (stencil . ,ly:measure-grouping::print)
- (thickness . 1)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (interfaces . (measure-grouping-interface
- side-position-interface))))))
+ (direction . ,UP)
+ (height . 2.0)
+ (padding . 2)
+ (side-axis . ,Y)
+ (staff-padding . 3)
+ (stencil . ,ly:measure-grouping::print)
+ (thickness . 1)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (interfaces . (measure-grouping-interface
+ side-position-interface))))))
(MelodyItem
. (
- (neutral-direction . ,DOWN)
- (meta . ((class . Item)
- (interfaces . (melody-spanner-interface))))))
+ (neutral-direction . ,DOWN)
+ (meta . ((class . Item)
+ (interfaces . (melody-spanner-interface))))))
(MensuralLigature
. (
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:mensural-ligature::print)
- (thickness . 1.3)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- mensural-ligature-interface))))))
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:mensural-ligature::print)
+ (thickness . 1.3)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ mensural-ligature-interface))))))
(MetronomeMark
. (
- (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
- (break-visibility . ,end-of-line-invisible)
- (direction . ,UP)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (outside-staff-horizontal-padding . 0.2)
- (outside-staff-priority . 1000)
- (padding . 0.8)
- (side-axis . ,Y)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:break-alignable-interface::self-align-callback))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (self-alignment-X . ,LEFT)
- (break-align-symbols . (time-signature))
- (non-break-align-symbols . (paper-column-interface))
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (break-alignable-interface
- font-interface
- metronome-mark-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
+ (break-visibility . ,end-of-line-invisible)
+ (direction . ,UP)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (outside-staff-horizontal-padding . 0.2)
+ (outside-staff-priority . 1000)
+ (padding . 0.8)
+ (side-axis . ,Y)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:break-alignable-interface::self-align-callback))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (self-alignment-X . ,LEFT)
+ (break-align-symbols . (time-signature))
+ (non-break-align-symbols . (paper-column-interface))
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (break-alignable-interface
+ font-interface
+ metronome-mark-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(MultiMeasureRest
. (
- (expand-limit . 10)
- (hair-thickness . 2.0)
- (round-up-exceptions . ())
- (padding . 1)
- (spacing-pair . (break-alignment . break-alignment))
- (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods)
- (stencil . ,ly:multi-measure-rest::print)
- (thick-thickness . 6.6)
- ;; See Wanske pp. 125
- (usable-duration-logs . ,(iota 4 -3))
- (Y-extent . ,(ly:make-unpure-pure-container ly:multi-measure-rest::height))
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- multi-measure-interface
- multi-measure-rest-interface
- rest-interface
- staff-symbol-referencer-interface))))))
+ (expand-limit . 10)
+ (hair-thickness . 2.0)
+ (round-up-exceptions . ())
+ (padding . 1)
+ (spacing-pair . (break-alignment . break-alignment))
+ (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods)
+ (stencil . ,ly:multi-measure-rest::print)
+ (thick-thickness . 6.6)
+ ;; See Wanske pp. 125
+ (usable-duration-logs . ,(iota 4 -3))
+ (Y-extent . ,(ly:make-unpure-pure-container ly:multi-measure-rest::height))
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ multi-measure-interface
+ multi-measure-rest-interface
+ rest-interface
+ staff-symbol-referencer-interface))))))
(MultiMeasureRestNumber
. (
- (bound-padding . 2.0)
- (direction . ,UP)
- (font-encoding . fetaText)
- (padding . 0.4)
- (self-alignment-X . ,CENTER)
- (side-axis . ,Y)
- (springs-and-rods . ,ly:multi-measure-rest::set-text-rods)
- (staff-padding . 0.4)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-centered-on-y-parent)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- multi-measure-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (bound-padding . 2.0)
+ (direction . ,UP)
+ (font-encoding . fetaText)
+ (padding . 0.4)
+ (self-alignment-X . ,CENTER)
+ (side-axis . ,Y)
+ (springs-and-rods . ,ly:multi-measure-rest::set-text-rods)
+ (staff-padding . 0.4)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-centered-on-y-parent)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ multi-measure-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(MultiMeasureRestText
. (
- (direction . ,UP)
- (outside-staff-priority . 450)
- (padding . 0.2)
- (self-alignment-X . ,CENTER)
- (skyline-horizontal-padding . 0.2)
- (staff-padding . 0.25)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-centered-on-y-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- multi-measure-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (direction . ,UP)
+ (outside-staff-priority . 450)
+ (padding . 0.2)
+ (self-alignment-X . ,CENTER)
+ (skyline-horizontal-padding . 0.2)
+ (staff-padding . 0.25)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-centered-on-y-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ multi-measure-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(NonMusicalPaperColumn
. (
- (allow-loose-spacing . #t)
- (axes . (,X))
- (before-line-breaking . ,ly:paper-column::before-line-breaking)
- (bound-alignment-interfaces . (break-alignment-interface))
- (full-measure-extra-space . 1.0)
- (horizontal-skylines . ,ly:separation-item::calc-skylines)
- ;; (stencil . ,ly:paper-column::print)
-
- (keep-inside-line . #t)
- (line-break-permission . allow)
- (non-musical . #t)
- (page-break-permission . allow)
-
- ;; debugging stuff: print column number.
- ;; (font-size . -6) (font-name . "sans") (Y-extent . #f)
-
- (X-extent . ,ly:axis-group-interface::width)
- (meta . ((class . Paper_column)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- font-interface
- paper-column-interface
- separation-item-interface
- spaceable-grob-interface))))))
+ (allow-loose-spacing . #t)
+ (axes . (,X))
+ (before-line-breaking . ,ly:paper-column::before-line-breaking)
+ (bound-alignment-interfaces . (break-alignment-interface))
+ (full-measure-extra-space . 1.0)
+ (horizontal-skylines . ,ly:separation-item::calc-skylines)
+ ;; (stencil . ,ly:paper-column::print)
+
+ (keep-inside-line . #t)
+ (line-break-permission . allow)
+ (non-musical . #t)
+ (page-break-permission . allow)
+
+ ;; debugging stuff: print column number.
+ ;; (font-size . -6) (font-name . "sans") (Y-extent . #f)
+
+ (X-extent . ,ly:axis-group-interface::width)
+ (meta . ((class . Paper_column)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ font-interface
+ paper-column-interface
+ separation-item-interface
+ spaceable-grob-interface))))))
(NoteCollision
. (
- (axes . (,X ,Y))
- (positioning-done . ,ly:note-collision-interface::calc-positioning-done)
- (prefer-dotted-right . #t)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Item)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- note-collision-interface))))))
+ (axes . (,X ,Y))
+ (positioning-done . ,ly:note-collision-interface::calc-positioning-done)
+ (prefer-dotted-right . #t)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Item)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ note-collision-interface))))))
(NoteColumn
. (
- (axes . (,X ,Y))
- (bound-alignment-interfaces . (rhythmic-head-interface stem-interface))
- (cross-staff . ,ly:axis-group-interface::cross-staff)
- (horizontal-skylines . ,ly:separation-item::calc-skylines)
- (skyline-vertical-padding . 0.15)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Item)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- note-column-interface
- separation-item-interface))))))
+ (axes . (,X ,Y))
+ (bound-alignment-interfaces . (rhythmic-head-interface stem-interface))
+ (cross-staff . ,ly:axis-group-interface::cross-staff)
+ (horizontal-skylines . ,ly:separation-item::calc-skylines)
+ (skyline-vertical-padding . 0.15)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Item)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ note-column-interface
+ separation-item-interface))))))
(NoteHead
. (
- (flexa-width . 2.0)
- (duration-log . ,note-head::calc-duration-log)
- (extra-spacing-height . ,ly:note-head::include-ledger-line-height)
- (glyph-name . ,note-head::calc-glyph-name)
- (ligature-flexa . #f)
- (stem-attachment . ,ly:note-head::calc-stem-attachment)
- (stencil . ,ly:note-head::print)
- (X-offset . ,ly:note-head::stem-x-shift)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- gregorian-ligature-interface
- ledgered-interface
+ (flexa-width . 2.0)
+ (duration-log . ,note-head::calc-duration-log)
+ (extra-spacing-height . ,ly:note-head::include-ledger-line-height)
+ (glyph-name . ,note-head::calc-glyph-name)
+ (ligature-flexa . #f)
+ (stem-attachment . ,ly:note-head::calc-stem-attachment)
+ (stencil . ,ly:note-head::print)
+ (X-offset . ,ly:note-head::stem-x-shift)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ gregorian-ligature-interface
+ ledgered-interface
ligature-head-interface
- mensural-ligature-interface
- note-head-interface
- rhythmic-grob-interface
- rhythmic-head-interface
- staff-symbol-referencer-interface
- vaticana-ligature-interface))))))
+ mensural-ligature-interface
+ note-head-interface
+ rhythmic-grob-interface
+ rhythmic-head-interface
+ staff-symbol-referencer-interface
+ vaticana-ligature-interface))))))
(NoteName
. (
- (stencil . ,ly:text-interface::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- note-name-interface
- text-interface))))))
+ (stencil . ,ly:text-interface::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ note-name-interface
+ text-interface))))))
(NoteSpacing
. (
- ;; Changed this from 0.75.
- ;; If you ever change this back, please document! --hwn
- (knee-spacing-correction . 1.0)
- (same-direction-correction . 0.25)
- (space-to-barline . #t)
- (stem-spacing-correction . 0.5)
- (meta . ((class . Item)
- (interfaces . (note-spacing-interface
- spacing-interface))))))
+ ;; Changed this from 0.75.
+ ;; If you ever change this back, please document! --hwn
+ (knee-spacing-correction . 1.0)
+ (same-direction-correction . 0.25)
+ (space-to-barline . #t)
+ (stem-spacing-correction . 0.5)
+ (meta . ((class . Item)
+ (interfaces . (note-spacing-interface
+ spacing-interface))))))
(OttavaBracket
. (
- (dash-fraction . 0.3)
- (direction . ,UP)
- (edge-height . (0 . 1.2))
- (font-shape . italic)
- (minimum-length . 1.0)
- (outside-staff-priority . 400)
- (padding . 0.5)
- (shorten-pair . (0.0 . -0.6))
- (staff-padding . 1.0)
- (stencil . ,ly:ottava-bracket::print)
- (style . dashed-line)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- horizontal-bracket-interface
- line-interface
- ottava-bracket-interface
- side-position-interface
- text-interface))))))
+ (dash-fraction . 0.3)
+ (direction . ,UP)
+ (edge-height . (0 . 1.2))
+ (font-shape . italic)
+ (minimum-length . 1.0)
+ (outside-staff-priority . 400)
+ (padding . 0.5)
+ (shorten-pair . (0.0 . -0.6))
+ (staff-padding . 1.0)
+ (stencil . ,ly:ottava-bracket::print)
+ (style . dashed-line)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ horizontal-bracket-interface
+ line-interface
+ ottava-bracket-interface
+ side-position-interface
+ text-interface))))))
(PaperColumn
. (
- (allow-loose-spacing . #t)
- (axes . (,X))
- (before-line-breaking . ,ly:paper-column::before-line-breaking)
- (bound-alignment-interfaces . (note-column-interface))
- (horizontal-skylines . ,ly:separation-item::calc-skylines)
- (keep-inside-line . #t)
- ;; 0.08 comes from spacing-horizontal-skyline.ly
- ;; allows double flat of F to be nestled over dots of C
- (skyline-vertical-padding . 0.08)
- ;; (stencil . ,ly:paper-column::print)
- (X-extent . ,ly:axis-group-interface::width)
-
- ;; debugging
- ;; (font-size . -6) (font-name . "sans") (Y-extent . #f)
- (meta . ((class . Paper_column)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- font-interface
- paper-column-interface
- separation-item-interface
- spaceable-grob-interface))))))
+ (allow-loose-spacing . #t)
+ (axes . (,X))
+ (before-line-breaking . ,ly:paper-column::before-line-breaking)
+ (bound-alignment-interfaces . (note-column-interface))
+ (horizontal-skylines . ,ly:separation-item::calc-skylines)
+ (keep-inside-line . #t)
+ ;; 0.08 comes from spacing-horizontal-skyline.ly
+ ;; allows double flat of F to be nestled over dots of C
+ (skyline-vertical-padding . 0.08)
+ ;; (stencil . ,ly:paper-column::print)
+ (X-extent . ,ly:axis-group-interface::width)
+
+ ;; debugging
+ ;; (font-size . -6) (font-name . "sans") (Y-extent . #f)
+ (meta . ((class . Paper_column)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ font-interface
+ paper-column-interface
+ separation-item-interface
+ spaceable-grob-interface))))))
(ParenthesesItem
. (
- (font-size . -6)
- (padding . 0.2)
- (stencil . ,parentheses-item::print)
- (stencils . ,parentheses-item::calc-parenthesis-stencils)
- (meta . ((class . Item)
- (interfaces . (font-interface
- parentheses-interface))))))
+ (font-size . -6)
+ (padding . 0.2)
+ (stencil . ,parentheses-item::print)
+ (stencils . ,parentheses-item::calc-parenthesis-stencils)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ parentheses-interface))))))
(PercentRepeat
. (
- (dot-negative-kern . 0.75)
- (font-encoding . fetaMusic)
- (slope . 1.0)
- (spacing-pair . (break-alignment . staff-bar))
- (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods)
- (stencil . ,ly:multi-measure-rest::percent)
- (thickness . 0.48)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- multi-measure-rest-interface
- percent-repeat-interface))))))
+ (dot-negative-kern . 0.75)
+ (font-encoding . fetaMusic)
+ (slope . 1.0)
+ (spacing-pair . (break-alignment . staff-bar))
+ (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods)
+ (stencil . ,ly:multi-measure-rest::percent)
+ (thickness . 0.48)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ multi-measure-rest-interface
+ percent-repeat-interface))))))
(PercentRepeatCounter
. (
- (direction . ,UP)
- (font-encoding . fetaText)
- (font-size . -2)
- (padding . 0.2)
- (self-alignment-X . ,CENTER)
- (staff-padding . 0.25)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-centered-on-y-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- percent-repeat-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (direction . ,UP)
+ (font-encoding . fetaText)
+ (font-size . -2)
+ (padding . 0.2)
+ (self-alignment-X . ,CENTER)
+ (staff-padding . 0.25)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-centered-on-y-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ percent-repeat-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(PhrasingSlur
. (
- (control-points . ,ly:slur::calc-control-points)
- (cross-staff . ,ly:slur::calc-cross-staff)
- (details . ,default-slur-details)
- (direction . ,ly:slur::calc-direction)
- (height-limit . 2.0)
- (minimum-length . 1.5)
- (ratio . 0.333)
- (spanner-id . "")
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:slur::print)
- (thickness . 1.1)
- (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents))
- (Y-extent . ,slur::height)
- (meta . ((class . Spanner)
- (interfaces . (slur-interface))))))
+ (control-points . ,ly:slur::calc-control-points)
+ (cross-staff . ,ly:slur::calc-cross-staff)
+ (details . ,default-slur-details)
+ (direction . ,ly:slur::calc-direction)
+ (height-limit . 2.0)
+ (minimum-length . 1.5)
+ (ratio . 0.333)
+ (spanner-id . "")
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:slur::print)
+ (thickness . 1.1)
+ (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents))
+ (Y-extent . ,slur::height)
+ (meta . ((class . Spanner)
+ (interfaces . (slur-interface))))))
;; an example of a text spanner
(PianoPedalBracket
. (
- (bound-padding . 1.0)
- (bracket-flare . (0.5 . 0.5))
- (direction . ,DOWN)
- (edge-height . (1.0 . 1.0))
- (shorten-pair . (0.0 . 0.0))
- (stencil . ,ly:piano-pedal-bracket::print)
- (style . line)
- (thickness . 1.0)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (meta . ((class . Spanner)
- (interfaces . (line-interface
- piano-pedal-bracket-interface
- piano-pedal-interface))))))
+ (bound-padding . 1.0)
+ (bracket-flare . (0.5 . 0.5))
+ (direction . ,DOWN)
+ (edge-height . (1.0 . 1.0))
+ (shorten-pair . (0.0 . 0.0))
+ (stencil . ,ly:piano-pedal-bracket::print)
+ (style . line)
+ (thickness . 1.0)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (meta . ((class . Spanner)
+ (interfaces . (line-interface
+ piano-pedal-bracket-interface
+ piano-pedal-interface))))))
(RehearsalMark
. (
- (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
- (baseline-skip . 2)
- (break-align-symbols . (staff-bar key-signature clef))
- (break-visibility . ,end-of-line-invisible)
- (direction . ,UP)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-size . 2)
- (non-musical . #t)
- (outside-staff-horizontal-padding . 0.12)
- (outside-staff-priority . 1500)
- (padding . 0.8)
- (self-alignment-X . ,CENTER)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:break-alignable-interface::self-align-callback))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
- (Y-offset . ,side-position-interface::y-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (break-alignable-interface
- font-interface
- mark-interface
- self-alignment-interface
- side-position-interface
- text-interface))))))
+ (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
+ (baseline-skip . 2)
+ (break-align-symbols . (staff-bar key-signature clef))
+ (break-visibility . ,end-of-line-invisible)
+ (direction . ,UP)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-size . 2)
+ (non-musical . #t)
+ (outside-staff-horizontal-padding . 0.12)
+ (outside-staff-priority . 1500)
+ (padding . 0.8)
+ (self-alignment-X . ,CENTER)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:break-alignable-interface::self-align-callback))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (break-alignable-interface
+ font-interface
+ mark-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface))))))
(RepeatSlash
. (
- (slash-negative-kern . 0.85)
- (slope . 1.7)
- (stencil . ,ly:percent-repeat-item-interface::beat-slash)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (thickness . 0.48)
- (meta . ((class . Item)
- (interfaces . (percent-repeat-interface
- percent-repeat-item-interface
- rhythmic-grob-interface))))))
+ (slash-negative-kern . 0.85)
+ (slope . 1.7)
+ (stencil . ,ly:percent-repeat-item-interface::beat-slash)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (thickness . 0.48)
+ (meta . ((class . Item)
+ (interfaces . (percent-repeat-interface
+ percent-repeat-item-interface
+ rhythmic-grob-interface))))))
(RepeatTie
. (
- (cross-staff . ,semi-tie::calc-cross-staff)
- (control-points . ,ly:semi-tie::calc-control-points)
- (details . ((ratio . 0.333)
- (height-limit . 1.0)))
- (direction . ,ly:tie::calc-direction)
- (head-direction . ,RIGHT)
- (stencil . ,ly:tie::print)
- (thickness . 1.0)
- (extra-spacing-height . (-0.5 . 0.5))
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (meta . ((class . Item)
- (interfaces . (semi-tie-interface))))))
+ (cross-staff . ,semi-tie::calc-cross-staff)
+ (control-points . ,ly:semi-tie::calc-control-points)
+ (details . ((ratio . 0.333)
+ (height-limit . 1.0)))
+ (direction . ,ly:tie::calc-direction)
+ (head-direction . ,RIGHT)
+ (stencil . ,ly:tie::print)
+ (thickness . 1.0)
+ (extra-spacing-height . (-0.5 . 0.5))
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (semi-tie-interface))))))
(RepeatTieColumn
. (
- (direction . ,ly:tie::calc-direction)
- (head-direction . ,ly:semi-tie-column::calc-head-direction)
- (positioning-done . ,ly:semi-tie-column::calc-positioning-done)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Item)
- (interfaces . (semi-tie-column-interface))))))
+ (direction . ,ly:tie::calc-direction)
+ (head-direction . ,ly:semi-tie-column::calc-head-direction)
+ (positioning-done . ,ly:semi-tie-column::calc-positioning-done)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Item)
+ (interfaces . (semi-tie-column-interface))))))
(Rest
. (
- (cross-staff . ,ly:rest::calc-cross-staff)
- (duration-log . ,stem::calc-duration-log)
- (minimum-distance . 0.25)
- (stencil . ,ly:rest::print)
- (X-extent . ,ly:rest::width)
- (Y-extent . ,(ly:make-unpure-pure-container ly:rest::height ly:rest::pure-height))
- (Y-offset . ,(ly:make-unpure-pure-container ly:rest::y-offset-callback))
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- rest-interface
- rhythmic-grob-interface
- rhythmic-head-interface
- staff-symbol-referencer-interface))))))
+ (cross-staff . ,ly:rest::calc-cross-staff)
+ (duration-log . ,stem::calc-duration-log)
+ (minimum-distance . 0.25)
+ (stencil . ,ly:rest::print)
+ (X-extent . ,ly:rest::width)
+ (Y-extent . ,(ly:make-unpure-pure-container ly:rest::height ly:rest::pure-height))
+ (Y-offset . ,(ly:make-unpure-pure-container ly:rest::y-offset-callback))
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ rest-interface
+ rhythmic-grob-interface
+ rhythmic-head-interface
+ staff-symbol-referencer-interface))))))
(RestCollision
. (
- (minimum-distance . 0.75)
- (positioning-done . ,ly:rest-collision::calc-positioning-done)
- (meta . ((class . Item)
- (interfaces . (rest-collision-interface))))))
+ (minimum-distance . 0.75)
+ (positioning-done . ,ly:rest-collision::calc-positioning-done)
+ (meta . ((class . Item)
+ (interfaces . (rest-collision-interface))))))
(Script
. (
- (add-stem-support . #t)
- (cross-staff . ,ly:script-interface::calc-cross-staff)
- (direction . ,ly:script-interface::calc-direction)
- (font-encoding . fetaMusic)
- (positioning-done . ,ly:script-interface::calc-positioning-done)
- (side-axis . ,Y)
-
- ;; padding set in script definitions.
- (slur-padding . 0.2)
- (staff-padding . 0.25)
-
- (stencil . ,ly:script-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (X-offset . ,script-interface::calc-x-offset)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Item)
- (interfaces . (font-interface
- script-interface
- side-position-interface))))))
+ (add-stem-support . #t)
+ (cross-staff . ,ly:script-interface::calc-cross-staff)
+ (direction . ,ly:script-interface::calc-direction)
+ (font-encoding . fetaMusic)
+ (positioning-done . ,ly:script-interface::calc-positioning-done)
+ (side-axis . ,Y)
+
+ ;; padding set in script definitions.
+ (slur-padding . 0.2)
+ (staff-padding . 0.25)
+
+ (stencil . ,ly:script-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (X-offset . ,script-interface::calc-x-offset)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ script-interface
+ side-position-interface))))))
(ScriptColumn
. (
- (before-line-breaking . ,ly:script-column::before-line-breaking)
- (meta . ((class . Item)
- (interfaces . (script-column-interface))))))
+ (before-line-breaking . ,ly:script-column::before-line-breaking)
+ (meta . ((class . Item)
+ (interfaces . (script-column-interface))))))
(ScriptRow
. (
- (before-line-breaking . ,ly:script-column::row-before-line-breaking)
- (meta . ((class . Item)
- (interfaces . (script-column-interface))))))
+ (before-line-breaking . ,ly:script-column::row-before-line-breaking)
+ (meta . ((class . Item)
+ (interfaces . (script-column-interface))))))
(Slur
. (
- (avoid-slur . inside)
- (control-points . ,ly:slur::calc-control-points)
- (cross-staff . ,ly:slur::calc-cross-staff)
- (details . ,default-slur-details)
- (direction . ,ly:slur::calc-direction)
- (height-limit . 2.0)
- (line-thickness . 0.8)
- (minimum-length . 1.5)
- (ratio . 0.25)
- (spanner-id . "")
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:slur::print)
- (thickness . 1.2)
- (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents))
- (Y-extent . ,slur::height)
- (meta . ((class . Spanner)
- (interfaces . (slur-interface))))))
+ (avoid-slur . inside)
+ (control-points . ,ly:slur::calc-control-points)
+ (cross-staff . ,ly:slur::calc-cross-staff)
+ (details . ,default-slur-details)
+ (direction . ,ly:slur::calc-direction)
+ (height-limit . 2.0)
+ (line-thickness . 0.8)
+ (minimum-length . 1.5)
+ (ratio . 0.25)
+ (spanner-id . "")
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:slur::print)
+ (thickness . 1.2)
+ (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents))
+ (Y-extent . ,slur::height)
+ (meta . ((class . Spanner)
+ (interfaces . (slur-interface))))))
(SostenutoPedal
. (
- (direction . ,RIGHT)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-shape . italic)
- (padding . 0.0) ;; padding relative to SostenutoPedalLineSpanner
- (self-alignment-X . ,CENTER)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- piano-pedal-script-interface
- self-alignment-interface
- text-interface))))))
+ (direction . ,RIGHT)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-shape . italic)
+ (padding . 0.0) ;; padding relative to SostenutoPedalLineSpanner
+ (self-alignment-X . ,CENTER)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ piano-pedal-script-interface
+ self-alignment-interface
+ text-interface))))))
(SostenutoPedalLineSpanner
. (
- (axes . (,Y))
- (cross-staff . ,ly:side-position-interface::calc-cross-staff)
- (direction . ,DOWN)
- (minimum-space . 1.0)
- (outside-staff-priority . 1000)
- (padding . 1.2)
- (side-axis . ,Y)
- (staff-padding . 1.0)
- (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- piano-pedal-interface
- side-position-interface))))))
+ (axes . (,Y))
+ (cross-staff . ,ly:side-position-interface::calc-cross-staff)
+ (direction . ,DOWN)
+ (minimum-space . 1.0)
+ (outside-staff-priority . 1000)
+ (padding . 1.2)
+ (side-axis . ,Y)
+ (staff-padding . 1.0)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ piano-pedal-interface
+ side-position-interface))))))
(SpacingSpanner
. (
- (average-spacing-wishes . #t)
- (base-shortest-duration . ,(ly:make-moment 3 16))
- (common-shortest-duration . ,ly:spacing-spanner::calc-common-shortest-duration)
- (shortest-duration-space . 2.0)
- (spacing-increment . 1.2)
- (springs-and-rods . ,ly:spacing-spanner::set-springs)
- (meta . ((class . Spanner)
- (interfaces . (spacing-options-interface
- spacing-spanner-interface))))))
+ (average-spacing-wishes . #t)
+ (base-shortest-duration . ,(ly:make-moment 3 16))
+ (common-shortest-duration . ,ly:spacing-spanner::calc-common-shortest-duration)
+ (shortest-duration-space . 2.0)
+ (spacing-increment . 1.2)
+ (springs-and-rods . ,ly:spacing-spanner::set-springs)
+ (meta . ((class . Spanner)
+ (interfaces . (spacing-options-interface
+ spacing-spanner-interface))))))
(SpanBar
. (
- (allow-span-bar . #t)
- (bar-extent . ,axis-group-interface::height)
- (before-line-breaking . ,ly:span-bar::before-line-breaking)
- (break-align-symbol . staff-bar)
- (cross-staff . #t)
- (glyph-name . ,ly:span-bar::calc-glyph-name)
- (layer . 0)
- (non-musical . #t)
- (stencil . ,ly:span-bar::print)
- (X-extent . ,ly:span-bar::width)
- (Y-extent . (+inf.0 . -inf.0))
- (meta . ((class . Item)
- (interfaces . (bar-line-interface
- font-interface
- span-bar-interface))))))
+ (allow-span-bar . #t)
+ (bar-extent . ,axis-group-interface::height)
+ (before-line-breaking . ,ly:span-bar::before-line-breaking)
+ (break-align-symbol . staff-bar)
+ (cross-staff . #t)
+ (glyph-name . ,ly:span-bar::calc-glyph-name)
+ (layer . 0)
+ (non-musical . #t)
+ (stencil . ,ly:span-bar::print)
+ (X-extent . ,ly:span-bar::width)
+ (Y-extent . (+inf.0 . -inf.0))
+ (meta . ((class . Item)
+ (interfaces . (bar-line-interface
+ font-interface
+ span-bar-interface))))))
(SpanBarStub
. (
(X-extent . ,(grob::inherit-parent-property
X 'X-extent))
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height)
- ;; we want this to be ignored, so empty, but the extra spacing height
- ;; should preserve the span bar's presence for horizontal spacing
- (Y-extent . ,pure-from-neighbor-interface::height-if-pure)
- (meta . ((class . Item)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (pure-from-neighbor-interface))))))
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height)
+ ;; we want this to be ignored, so empty, but the extra spacing height
+ ;; should preserve the span bar's presence for horizontal spacing
+ (Y-extent . ,pure-from-neighbor-interface::height-if-pure)
+ (meta . ((class . Item)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
+ (interfaces . (pure-from-neighbor-interface))))))
(StaffGrouper
. (
- (staff-staff-spacing . ((basic-distance . 9)
- (minimum-distance . 7)
- (padding . 1)
+ (staff-staff-spacing . ((basic-distance . 9)
+ (minimum-distance . 7)
+ (padding . 1)
(stretchability . 5)))
- (staffgroup-staff-spacing . ((basic-distance . 10.5)
- (minimum-distance . 8)
- (padding . 1)
+ (staffgroup-staff-spacing . ((basic-distance . 10.5)
+ (minimum-distance . 8)
+ (padding . 1)
(stretchability . 9)))
- (meta . ((class . Spanner)
- (interfaces . (staff-grouper-interface))))))
+ (meta . ((class . Spanner)
+ (interfaces . (staff-grouper-interface))))))
(StaffSpacing
. (
- (non-musical . #t)
- (stem-spacing-correction . 0.4)
- (meta . ((class . Item)
- (interfaces . (spacing-interface
- staff-spacing-interface))))))
+ (non-musical . #t)
+ (stem-spacing-correction . 0.4)
+ (meta . ((class . Item)
+ (interfaces . (spacing-interface
+ staff-spacing-interface))))))
(StaffSymbol
. (
- (layer . 0)
- (ledger-line-thickness . (1.0 . 0.1))
- (line-count . 5)
- (stencil . ,ly:staff-symbol::print)
- (Y-extent . ,(ly:make-unpure-pure-container ly:staff-symbol::height))
- (meta . ((class . Spanner)
- (interfaces . (staff-symbol-interface))))))
+ (layer . 0)
+ (ledger-line-thickness . (1.0 . 0.1))
+ (line-count . 5)
+ (stencil . ,ly:staff-symbol::print)
+ (Y-extent . ,(ly:make-unpure-pure-container ly:staff-symbol::height))
+ (meta . ((class . Spanner)
+ (interfaces . (staff-symbol-interface))))))
(StanzaNumber
. (
- (direction . ,LEFT)
- (font-series . bold)
- (padding . 1.0)
- (side-axis . ,X)
- (stencil . ,ly:text-interface::print)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- side-position-interface
- stanza-number-interface
- text-interface))))))
+ (direction . ,LEFT)
+ (font-series . bold)
+ (padding . 1.0)
+ (side-axis . ,X)
+ (stencil . ,ly:text-interface::print)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ side-position-interface
+ stanza-number-interface
+ text-interface))))))
(Stem
. (
- (beamlet-default-length . (1.1 . 1.1))
- (beamlet-max-length-proportion . (0.75 . 0.75))
- (cross-staff . ,ly:stem::calc-cross-staff)
- (default-direction . ,ly:stem::calc-default-direction)
- (details
- . (
- ;; 3.5 (or 3 measured from note head) is standard length
- ;; 32nd, 64th, 128th flagged stems should be longer
- (lengths . (3.5 3.5 3.5 4.25 5.0 6.0))
-
- ;; FIXME. 3.5 yields too long beams (according to Ross and
- ;; looking at Baerenreiter examples) for a number of common
- ;; boundary cases. Subtracting half a beam thickness fixes
- ;; this, but the bug may well be somewhere else.
-
- ;; FIXME this should come from 'lengths
- (beamed-lengths . (3.26 3.5 3.6))
-
- ;; The 'normal' minima
- (beamed-minimum-free-lengths . (1.83 1.5 1.25))
+ (beamlet-default-length . (1.1 . 1.1))
+ (beamlet-max-length-proportion . (0.75 . 0.75))
+ (cross-staff . ,ly:stem::calc-cross-staff)
+ (default-direction . ,ly:stem::calc-default-direction)
+ (details
+ . (
+ ;; 3.5 (or 3 measured from note head) is standard length
+ ;; 32nd, 64th, 128th flagged stems should be longer
+ (lengths . (3.5 3.5 3.5 4.25 5.0 6.0))
+
+ ;; FIXME. 3.5 yields too long beams (according to Ross and
+ ;; looking at Baerenreiter examples) for a number of common
+ ;; boundary cases. Subtracting half a beam thickness fixes
+ ;; this, but the bug may well be somewhere else.
+
+ ;; FIXME this should come from 'lengths
+ (beamed-lengths . (3.26 3.5 3.6))
+
+ ;; The 'normal' minima
+ (beamed-minimum-free-lengths . (1.83 1.5 1.25))
;;(beamed-minimum-free-lengths . (2.0 1.83 1.25))
- ;; The 'extreme case' minima
- (beamed-extreme-minimum-free-lengths . (2.0 1.25))
+ ;; The 'extreme case' minima
+ (beamed-extreme-minimum-free-lengths . (2.0 1.25))
- ;; Stems in unnatural (forced) direction should be shortened by
- ;; one staff space, according to [Roush & Gourlay].
- ;; Flagged stems we shorten only half a staff space.
- (stem-shorten . (1.0 0.5))
+ ;; Stems in unnatural (forced) direction should be shortened by
+ ;; one staff space, according to [Roush & Gourlay].
+ ;; Flagged stems we shorten only half a staff space.
+ (stem-shorten . (1.0 0.5))
- ))
+ ))
- ;; We use the normal minima as minimum for the ideal lengths,
- ;; and the extreme minima as abolute minimum length.
+ ;; We use the normal minima as minimum for the ideal lengths,
+ ;; and the extreme minima as abolute minimum length.
- (direction . ,ly:stem::calc-direction)
- (duration-log . ,stem::calc-duration-log)
+ (direction . ,ly:stem::calc-direction)
+ (duration-log . ,stem::calc-duration-log)
(length . ,(ly:make-unpure-pure-container ly:stem::calc-length ly:stem::pure-calc-length))
- (neutral-direction . ,DOWN)
- (positioning-done . ,ly:stem::calc-positioning-done)
- (stem-info . ,ly:stem::calc-stem-info)
- (stem-begin-position . ,(ly:make-unpure-pure-container ly:stem::calc-stem-begin-position ly:stem::pure-calc-stem-begin-position))
- (stencil . ,ly:stem::print)
- (thickness . 1.3)
- (X-extent . ,ly:stem::width)
- (X-offset . ,ly:stem::offset-callback)
- (Y-extent . ,(ly:make-unpure-pure-container ly:stem::height ly:stem::pure-height))
- (Y-offset . ,staff-symbol-referencer::callback)
- (meta . ((class . Item)
- (interfaces . (stem-interface))))))
+ (neutral-direction . ,DOWN)
+ (positioning-done . ,ly:stem::calc-positioning-done)
+ (stem-info . ,ly:stem::calc-stem-info)
+ (stem-begin-position . ,(ly:make-unpure-pure-container ly:stem::calc-stem-begin-position ly:stem::pure-calc-stem-begin-position))
+ (stencil . ,ly:stem::print)
+ (thickness . 1.3)
+ (X-extent . ,ly:stem::width)
+ (X-offset . ,ly:stem::offset-callback)
+ (Y-extent . ,(ly:make-unpure-pure-container ly:stem::height ly:stem::pure-height))
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (meta . ((class . Item)
+ (interfaces . (stem-interface))))))
(StemStub
. (
(X-extent . ,stem-stub::width)
- (extra-spacing-height . ,stem-stub::extra-spacing-height)
- (Y-extent . ,(ly:make-unpure-pure-container #f stem-stub::pure-height))
- (meta . ((class . Item)
- (interfaces . ())))))
+ (extra-spacing-height . ,stem-stub::extra-spacing-height)
+ (Y-extent . ,(ly:make-unpure-pure-container #f stem-stub::pure-height))
+ (meta . ((class . Item)
+ (interfaces . ())))))
(StemTremolo
. (
- (beam-thickness . 0.48) ; staff-space
- (beam-width . ,ly:stem-tremolo::calc-width) ; staff-space
- (direction . ,ly:stem-tremolo::calc-direction)
- (slope . ,ly:stem-tremolo::calc-slope)
- (stencil . ,ly:stem-tremolo::print)
- (style . ,ly:stem-tremolo::calc-style)
- (X-extent . ,ly:stem-tremolo::width)
- (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:stem-tremolo::pure-height))
- (X-offset . ,(ly:make-simple-closure
- `(,+
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::centered-on-x-parent))
- ,(ly:make-simple-closure
- (list ly:self-alignment-interface::x-aligned-on-self)))))
+ (beam-thickness . 0.48) ; staff-space
+ (beam-width . ,ly:stem-tremolo::calc-width) ; staff-space
+ (direction . ,ly:stem-tremolo::calc-direction)
+ (slope . ,ly:stem-tremolo::calc-slope)
+ (stencil . ,ly:stem-tremolo::print)
+ (style . ,ly:stem-tremolo::calc-style)
+ (X-extent . ,ly:stem-tremolo::width)
+ (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:stem-tremolo::pure-height))
+ (X-offset . ,(ly:make-simple-closure
+ `(,+
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::centered-on-x-parent))
+ ,(ly:make-simple-closure
+ (list ly:self-alignment-interface::x-aligned-on-self)))))
(Y-offset . ,(ly:make-unpure-pure-container ly:stem-tremolo::calc-y-offset ly:stem-tremolo::pure-calc-y-offset))
- (meta . ((class . Item)
- (interfaces . (self-alignment-interface
+ (meta . ((class . Item)
+ (interfaces . (self-alignment-interface
stem-tremolo-interface))))))
(StringNumber
. (
- (avoid-slur . around)
- (cross-staff . ,script-or-side-position-cross-staff)
- (font-encoding . fetaText)
- (font-size . -5) ; don't overlap when next to heads.
- (padding . 0.5)
- (script-priority . 100)
- (self-alignment-X . ,CENTER)
- (self-alignment-Y . ,CENTER)
- (staff-padding . 0.5)
- (stencil . ,print-circled-text-callback)
- (text . ,string-number::calc-text)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- self-alignment-interface
- side-position-interface
- string-number-interface
- text-interface
- text-script-interface))))))
+ (avoid-slur . around)
+ (cross-staff . ,script-or-side-position-cross-staff)
+ (font-encoding . fetaText)
+ (font-size . -5) ; don't overlap when next to heads.
+ (padding . 0.5)
+ (script-priority . 100)
+ (self-alignment-X . ,CENTER)
+ (self-alignment-Y . ,CENTER)
+ (staff-padding . 0.5)
+ (stencil . ,print-circled-text-callback)
+ (text . ,string-number::calc-text)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ self-alignment-interface
+ side-position-interface
+ string-number-interface
+ text-interface
+ text-script-interface))))))
(StrokeFinger
. (
- (digit-names . #("p" "i" "m" "a" "x"))
- (font-shape . italic)
- (font-size . -4) ; don't overlap when next to heads.
- (padding . 0.5)
- (script-priority . 100)
- (self-alignment-X . ,CENTER)
- (self-alignment-Y . ,CENTER)
- (staff-padding . 0.5)
- (stencil . ,ly:text-interface::print)
- (text . ,stroke-finger::calc-text)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- self-alignment-interface
- side-position-interface
- stroke-finger-interface
- text-interface
- text-script-interface))))))
+ (digit-names . #("p" "i" "m" "a" "x"))
+ (font-shape . italic)
+ (font-size . -4) ; don't overlap when next to heads.
+ (padding . 0.5)
+ (script-priority . 100)
+ (self-alignment-X . ,CENTER)
+ (self-alignment-Y . ,CENTER)
+ (staff-padding . 0.5)
+ (stencil . ,ly:text-interface::print)
+ (text . ,stroke-finger::calc-text)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ self-alignment-interface
+ side-position-interface
+ stroke-finger-interface
+ text-interface
+ text-script-interface))))))
(SustainPedal
. (
- (direction . ,RIGHT)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (padding . 0.0) ;; padding relative to SustainPedalLineSpanner
- (self-alignment-X . ,CENTER)
- (stencil . ,ly:sustain-pedal::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- piano-pedal-interface
- piano-pedal-script-interface
- self-alignment-interface
- text-interface))))))
+ (direction . ,RIGHT)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (padding . 0.0) ;; padding relative to SustainPedalLineSpanner
+ (self-alignment-X . ,CENTER)
+ (stencil . ,ly:sustain-pedal::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ piano-pedal-interface
+ piano-pedal-script-interface
+ self-alignment-interface
+ text-interface))))))
(SustainPedalLineSpanner
. (
- (axes . (,Y))
- (cross-staff . ,ly:side-position-interface::calc-cross-staff)
- (direction . ,DOWN)
- (minimum-space . 1.0)
- (outside-staff-priority . 1000)
- (padding . 1.2)
- (side-axis . ,Y)
- (staff-padding . 1.2)
- (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- piano-pedal-interface
- side-position-interface))))))
+ (axes . (,Y))
+ (cross-staff . ,ly:side-position-interface::calc-cross-staff)
+ (direction . ,DOWN)
+ (minimum-space . 1.0)
+ (outside-staff-priority . 1000)
+ (padding . 1.2)
+ (side-axis . ,Y)
+ (staff-padding . 1.2)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ piano-pedal-interface
+ side-position-interface))))))
(System
. (
- (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
- (axes . (,X ,Y))
- (outside-staff-placement-directive . left-to-right-polite)
- (skyline-horizontal-padding . 1.0)
- (vertical-skylines . ,ly:axis-group-interface::calc-skylines)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,(ly:make-unpure-pure-container ly:system::height ly:system::calc-pure-height))
- (meta . ((class . System)
- (object-callbacks . ((footnotes-before-line-breaking . ,ly:system::footnotes-before-line-breaking)
- (footnotes-after-line-breaking . ,ly:system::footnotes-after-line-breaking)
- (pure-relevant-grobs . ,ly:system::calc-pure-relevant-grobs)
- (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (vertical-skyline-elements . ,ly:system::vertical-skyline-elements)
+ (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
+ (axes . (,X ,Y))
+ (outside-staff-placement-directive . left-to-right-polite)
+ (skyline-horizontal-padding . 1.0)
+ (vertical-skylines . ,ly:axis-group-interface::calc-skylines)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,(ly:make-unpure-pure-container ly:system::height ly:system::calc-pure-height))
+ (meta . ((class . System)
+ (object-callbacks . ((footnotes-before-line-breaking . ,ly:system::footnotes-before-line-breaking)
+ (footnotes-after-line-breaking . ,ly:system::footnotes-after-line-breaking)
+ (pure-relevant-grobs . ,ly:system::calc-pure-relevant-grobs)
+ (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (vertical-skyline-elements . ,ly:system::vertical-skyline-elements)
(vertical-alignment . ,ly:system::get-vertical-alignment)))
- (interfaces . (axis-group-interface
- system-interface))))))
+ (interfaces . (axis-group-interface
+ system-interface))))))
(SystemStartBar
. (
- (collapse-height . 5.0)
- (direction . ,LEFT)
-
- (cross-staff . #t)
- ;; ugh--hardcoded.
- (padding . -0.1) ;; bar must cover rounded ending of staff line.
- (stencil . ,ly:system-start-delimiter::print)
- (style . bar-line)
- (thickness . 1.6)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (side-position-interface
- system-start-delimiter-interface))))))
+ (collapse-height . 5.0)
+ (direction . ,LEFT)
+
+ (cross-staff . #t)
+ ;; ugh--hardcoded.
+ (padding . -0.1) ;; bar must cover rounded ending of staff line.
+ (stencil . ,ly:system-start-delimiter::print)
+ (style . bar-line)
+ (thickness . 1.6)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (side-position-interface
+ system-start-delimiter-interface))))))
(SystemStartBrace
. (
- (collapse-height . 5.0)
- (direction . ,LEFT)
- (font-encoding . fetaBraces)
- (cross-staff . #t)
- (padding . 0.3)
- (stencil . ,ly:system-start-delimiter::print)
- (style . brace)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- side-position-interface
- system-start-delimiter-interface))))))
+ (collapse-height . 5.0)
+ (direction . ,LEFT)
+ (font-encoding . fetaBraces)
+ (cross-staff . #t)
+ (padding . 0.3)
+ (stencil . ,ly:system-start-delimiter::print)
+ (style . brace)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ side-position-interface
+ system-start-delimiter-interface))))))
(SystemStartBracket
. (
- (collapse-height . 5.0)
- (direction . ,LEFT)
- (cross-staff . #t)
- (padding . 0.8)
- (stencil . ,ly:system-start-delimiter::print)
- (style . bracket)
- (thickness . 0.45)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- side-position-interface
- system-start-delimiter-interface))))))
+ (collapse-height . 5.0)
+ (direction . ,LEFT)
+ (cross-staff . #t)
+ (padding . 0.8)
+ (stencil . ,ly:system-start-delimiter::print)
+ (style . bracket)
+ (thickness . 0.45)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ side-position-interface
+ system-start-delimiter-interface))))))
(SystemStartSquare
. (
- (direction . ,LEFT)
- (cross-staff . #t)
- (stencil . ,ly:system-start-delimiter::print)
- (style . line-bracket)
- (thickness . 1.0)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- side-position-interface
- system-start-delimiter-interface))))))
+ (direction . ,LEFT)
+ (cross-staff . #t)
+ (stencil . ,ly:system-start-delimiter::print)
+ (style . line-bracket)
+ (thickness . 1.0)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ side-position-interface
+ system-start-delimiter-interface))))))
(TabNoteHead
. (
- (details . ((cautionary-properties . ((angularity . 0.4)
- (half-thickness . 0.075)
- (padding . 0)
- (procedure . ,parenthesize-stencil)
- (width . 0.25)))
- (head-offset . 3/5)
- (harmonic-properties . ((angularity . 2)
- (half-thickness . 0.075)
- (padding . 0)
- (procedure . ,parenthesize-stencil)
- (width . 0.25)))
- (repeat-tied-properties . ((note-head-visible . #t)
- (parenthesize . #t)))
- (tied-properties . ((break-visibility . ,begin-of-line-visible)
- (parenthesize . #t)))))
-
- (direction . ,CENTER)
- (duration-log . ,note-head::calc-duration-log)
- (font-series . bold)
- (font-size . -2)
- (stem-attachment . (0.0 . 1.35))
- (stencil . ,tab-note-head::print)
- (whiteout . #t)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- note-head-interface
- rhythmic-grob-interface
- rhythmic-head-interface
- staff-symbol-referencer-interface
- tab-note-head-interface
- text-interface))))))
+ (details . ((cautionary-properties . ((angularity . 0.4)
+ (half-thickness . 0.075)
+ (padding . 0)
+ (procedure . ,parenthesize-stencil)
+ (width . 0.25)))
+ (head-offset . 3/5)
+ (harmonic-properties . ((angularity . 2)
+ (half-thickness . 0.075)
+ (padding . 0)
+ (procedure . ,parenthesize-stencil)
+ (width . 0.25)))
+ (repeat-tied-properties . ((note-head-visible . #t)
+ (parenthesize . #t)))
+ (tied-properties . ((break-visibility . ,begin-of-line-visible)
+ (parenthesize . #t)))))
+
+ (direction . ,CENTER)
+ (duration-log . ,note-head::calc-duration-log)
+ (font-series . bold)
+ (font-size . -2)
+ (stem-attachment . (0.0 . 1.35))
+ (stencil . ,tab-note-head::print)
+ (whiteout . #t)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ note-head-interface
+ rhythmic-grob-interface
+ rhythmic-head-interface
+ staff-symbol-referencer-interface
+ tab-note-head-interface
+ text-interface))))))
(TextScript
. (
- (avoid-slur . around)
- (cross-staff . ,script-or-side-position-cross-staff)
- (direction . ,DOWN)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (outside-staff-horizontal-padding . 0.12)
- (outside-staff-priority . 450)
-
- ;; sync with Fingering ?
- (padding . 0.3)
-
- (script-priority . 200)
- (side-axis . ,Y)
- (slur-padding . 0.5)
- (staff-padding . 0.5)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- ;; todo: add X self alignment?
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Item)
- (interfaces . (font-interface
- instrument-specific-markup-interface
- self-alignment-interface
- side-position-interface
- text-interface
- text-script-interface))))))
+ (avoid-slur . around)
+ (cross-staff . ,script-or-side-position-cross-staff)
+ (direction . ,DOWN)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (outside-staff-horizontal-padding . 0.12)
+ (outside-staff-priority . 450)
+
+ ;; sync with Fingering ?
+ (padding . 0.3)
+
+ (script-priority . 200)
+ (side-axis . ,Y)
+ (slur-padding . 0.5)
+ (staff-padding . 0.5)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ ;; todo: add X self alignment?
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ instrument-specific-markup-interface
+ self-alignment-interface
+ side-position-interface
+ text-interface
+ text-script-interface))))))
(TextSpanner
. (
- (bound-details . ((left . ((Y . 0)
- (padding . 0.25)
- (attach-dir . ,LEFT)
- ))
- (left-broken . ((attach-dir . ,RIGHT)))
- (right . ((Y . 0)
- (padding . 0.25)
- ))
- ))
- (dash-fraction . 0.2)
- (dash-period . 3.0)
- (direction . ,UP)
- (font-shape . italic)
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
- (outside-staff-priority . 350)
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (side-axis . ,Y)
- (staff-padding . 0.8)
- (stencil . ,ly:line-spanner::print)
- (style . dashed-line)
- (Y-offset . ,side-position-interface::y-aligned-side)
-
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- line-interface
- line-spanner-interface
- side-position-interface))))))
+ (bound-details . ((left . ((Y . 0)
+ (padding . 0.25)
+ (attach-dir . ,LEFT)
+ ))
+ (left-broken . ((attach-dir . ,RIGHT)))
+ (right . ((Y . 0)
+ (padding . 0.25)
+ ))
+ ))
+ (dash-fraction . 0.2)
+ (dash-period . 3.0)
+ (direction . ,UP)
+ (font-shape . italic)
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
+ (outside-staff-priority . 350)
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (side-axis . ,Y)
+ (staff-padding . 0.8)
+ (stencil . ,ly:line-spanner::print)
+ (style . dashed-line)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ line-interface
+ line-spanner-interface
+ side-position-interface))))))
(Tie
. (
- (avoid-slur . inside)
- (control-points . ,ly:tie::calc-control-points)
- (details . (
- ;; for a full list, see tie-details.cc
- (ratio . 0.333)
- (center-staff-line-clearance . 0.6)
- (tip-staff-line-clearance . 0.45)
- (note-head-gap . 0.2)
- (stem-gap . 0.35)
- (height-limit . 1.0)
- (horizontal-distance-penalty-factor . 10)
- (same-dir-as-stem-penalty . 8)
- (min-length-penalty-factor . 26)
- (tie-tie-collision-distance . 0.45)
- (tie-tie-collision-penalty . 25.0)
- (intra-space-threshold . 1.25)
- (outer-tie-vertical-distance-symmetry-penalty-factor . 10)
- (outer-tie-length-symmetry-penalty-factor . 10)
- (vertical-distance-penalty-factor . 7)
- (outer-tie-vertical-gap . 0.25)
- (multi-tie-region-size . 3)
- (single-tie-region-size . 4)
- (between-length-limit . 1.0)))
-
- (direction . ,ly:tie::calc-direction)
- (font-size . -6)
- (line-thickness . 0.8)
- (neutral-direction . ,UP)
- (springs-and-rods . ,ly:spanner::set-spacing-rods)
- (stencil . ,ly:tie::print)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (thickness . 1.2)
- (meta . ((class . Spanner)
- (interfaces . (tie-interface))))))
+ (avoid-slur . inside)
+ (control-points . ,ly:tie::calc-control-points)
+ (details . (
+ ;; for a full list, see tie-details.cc
+ (ratio . 0.333)
+ (center-staff-line-clearance . 0.6)
+ (tip-staff-line-clearance . 0.45)
+ (note-head-gap . 0.2)
+ (stem-gap . 0.35)
+ (height-limit . 1.0)
+ (horizontal-distance-penalty-factor . 10)
+ (same-dir-as-stem-penalty . 8)
+ (min-length-penalty-factor . 26)
+ (tie-tie-collision-distance . 0.45)
+ (tie-tie-collision-penalty . 25.0)
+ (intra-space-threshold . 1.25)
+ (outer-tie-vertical-distance-symmetry-penalty-factor . 10)
+ (outer-tie-length-symmetry-penalty-factor . 10)
+ (vertical-distance-penalty-factor . 7)
+ (outer-tie-vertical-gap . 0.25)
+ (multi-tie-region-size . 3)
+ (single-tie-region-size . 4)
+ (between-length-limit . 1.0)))
+
+ (direction . ,ly:tie::calc-direction)
+ (font-size . -6)
+ (line-thickness . 0.8)
+ (neutral-direction . ,UP)
+ (springs-and-rods . ,ly:spanner::set-spacing-rods)
+ (stencil . ,ly:tie::print)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (thickness . 1.2)
+ (meta . ((class . Spanner)
+ (interfaces . (tie-interface))))))
(TieColumn
. (
- (before-line-breaking . ,ly:tie-column::before-line-breaking)
- (positioning-done . ,ly:tie-column::calc-positioning-done)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (tie-column-interface))))))
+ (before-line-breaking . ,ly:tie-column::before-line-breaking)
+ (positioning-done . ,ly:tie-column::calc-positioning-done)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (tie-column-interface))))))
(TimeSignature
. (
- (avoid-slur . inside)
- (break-align-anchor
- . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
- (break-align-symbol . time-signature)
- (break-align-anchor-alignment . ,LEFT)
- (break-visibility . ,all-visible)
- (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
- (extra-spacing-width . (0.0 . 0.8))
- (non-musical . #t)
- (space-alist . (
- (cue-clef . (extra-space . 1.5))
- (first-note . (fixed-space . 2.0))
- (right-edge . (extra-space . 0.5))
- (staff-bar . (extra-space . 1.0))))
- (stencil . ,ly:time-signature::print)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (style . C)
- (meta . ((class . Item)
+ (avoid-slur . inside)
+ (break-align-anchor
+ . ,ly:break-aligned-interface::calc-extent-aligned-anchor)
+ (break-align-symbol . time-signature)
+ (break-align-anchor-alignment . ,LEFT)
+ (break-visibility . ,all-visible)
+ (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff)
+ (extra-spacing-width . (0.0 . 0.8))
+ (non-musical . #t)
+ (space-alist . (
+ (cue-clef . (extra-space . 1.5))
+ (first-note . (fixed-space . 2.0))
+ (right-edge . (extra-space . 0.5))
+ (staff-bar . (extra-space . 1.0))))
+ (stencil . ,ly:time-signature::print)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (style . C)
+ (meta . ((class . Item)
(object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
(pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs)))
- (interfaces . (break-aligned-interface
- font-interface
- pure-from-neighbor-interface
- time-signature-interface))))))
+ (interfaces . (break-aligned-interface
+ font-interface
+ pure-from-neighbor-interface
+ time-signature-interface))))))
(TrillPitchAccidental
. (
- (direction . ,LEFT)
- (font-size . -4)
- (glyph-name-alist . ,standard-alteration-glyph-name-alist)
- (padding . 0.2)
- (side-axis . ,X)
- (stencil . ,ly:accidental-interface::print)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . ,accidental-interface::height)
- (meta . ((class . Item)
- (interfaces . (accidental-interface
- font-interface
- inline-accidental-interface
- side-position-interface
- trill-pitch-accidental-interface))))))
+ (direction . ,LEFT)
+ (font-size . -4)
+ (glyph-name-alist . ,standard-alteration-glyph-name-alist)
+ (padding . 0.2)
+ (side-axis . ,X)
+ (stencil . ,ly:accidental-interface::print)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . ,accidental-interface::height)
+ (meta . ((class . Item)
+ (interfaces . (accidental-interface
+ font-interface
+ inline-accidental-interface
+ side-position-interface
+ trill-pitch-accidental-interface))))))
(TrillPitchGroup
. (
- (axes . (,X))
- (direction . ,RIGHT)
- (font-size . -4)
- (padding . 0.3)
- (side-axis . ,X)
- (stencil . ,parenthesize-elements)
- (stencils . ,parentheses-item::calc-parenthesis-stencils)
- (X-offset . ,ly:side-position-interface::x-aligned-side)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (axis-group-interface
- font-interface
- note-head-interface
- parentheses-interface
- side-position-interface))))))
+ (axes . (,X))
+ (direction . ,RIGHT)
+ (font-size . -4)
+ (padding . 0.3)
+ (side-axis . ,X)
+ (stencil . ,parenthesize-elements)
+ (stencils . ,parentheses-item::calc-parenthesis-stencils)
+ (X-offset . ,ly:side-position-interface::x-aligned-side)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (axis-group-interface
+ font-interface
+ note-head-interface
+ parentheses-interface
+ side-position-interface))))))
(TrillPitchHead
. (
- (duration-log . 2)
- (font-size . -4)
- (stencil . ,ly:note-head::print)
- (Y-offset . ,staff-symbol-referencer::callback)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (meta . ((class . Item)
- (interfaces . (font-interface
- ledgered-interface
- pitched-trill-interface
- rhythmic-head-interface
- staff-symbol-referencer-interface))))))
+ (duration-log . 2)
+ (font-size . -4)
+ (stencil . ,ly:note-head::print)
+ (Y-offset . ,staff-symbol-referencer::callback)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ ledgered-interface
+ pitched-trill-interface
+ rhythmic-head-interface
+ staff-symbol-referencer-interface))))))
(TrillSpanner
. (
- (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
- (bound-details . ((left . ((text . ,(make-musicglyph-markup "scripts.trill"))
- (Y . 0)
- (stencil-offset . (-0.5 . -1))
- (padding . 0.5)
- (attach-dir . ,CENTER)
- ))
- (left-broken . ((end-on-note . #t)))
- (right . ((Y . 0)))
- ))
- (direction . ,UP)
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
- (outside-staff-priority . 50)
- (padding . 0.5)
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (side-axis . ,Y)
- (staff-padding . 1.0)
- (stencil . ,ly:line-spanner::print)
- (style . trill)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- line-interface
- line-spanner-interface
- side-position-interface
- trill-spanner-interface))))))
+ (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
+ (bound-details . ((left . ((text . ,(make-musicglyph-markup "scripts.trill"))
+ (Y . 0)
+ (stencil-offset . (-0.5 . -1))
+ (padding . 0.5)
+ (attach-dir . ,CENTER)
+ ))
+ (left-broken . ((end-on-note . #t)))
+ (right . ((Y . 0)))
+ ))
+ (direction . ,UP)
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
+ (outside-staff-priority . 50)
+ (padding . 0.5)
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (side-axis . ,Y)
+ (staff-padding . 1.0)
+ (stencil . ,ly:line-spanner::print)
+ (style . trill)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ line-interface
+ line-spanner-interface
+ side-position-interface
+ trill-spanner-interface))))))
(TupletBracket
. (
- (avoid-scripts . #t)
- (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
- (cross-staff . ,ly:tuplet-bracket::calc-cross-staff)
- (direction . ,ly:tuplet-bracket::calc-direction)
- (edge-height . (0.7 . 0.7))
- (full-length-to-extent . #t)
- (padding . 1.1)
- (positions . ,ly:tuplet-bracket::calc-positions)
- (shorten-pair . (-0.2 . -0.2))
- (staff-padding . 0.25)
- (stencil . ,ly:tuplet-bracket::print)
- (thickness . 1.6)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (X-positions . ,ly:tuplet-bracket::calc-x-positions)
-
- (meta . ((class . Spanner)
- (interfaces . (line-interface
- tuplet-bracket-interface))))))
+ (avoid-scripts . #t)
+ (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors)
+ (cross-staff . ,ly:tuplet-bracket::calc-cross-staff)
+ (direction . ,ly:tuplet-bracket::calc-direction)
+ (edge-height . (0.7 . 0.7))
+ (full-length-to-extent . #t)
+ (padding . 1.1)
+ (positions . ,ly:tuplet-bracket::calc-positions)
+ (shorten-pair . (-0.2 . -0.2))
+ (staff-padding . 0.25)
+ (stencil . ,ly:tuplet-bracket::print)
+ (thickness . 1.6)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (X-positions . ,ly:tuplet-bracket::calc-x-positions)
+
+ (meta . ((class . Spanner)
+ (interfaces . (line-interface
+ tuplet-bracket-interface))))))
(TupletNumber
. (
- (avoid-slur . inside)
- (cross-staff . ,ly:tuplet-number::calc-cross-staff)
- (direction . ,tuplet-number::calc-direction)
- (font-shape . italic)
- (font-size . -2)
- (stencil . ,ly:tuplet-number::print)
- (text . ,tuplet-number::calc-denominator-text)
- (X-offset . ,ly:tuplet-number::calc-x-offset)
- (Y-offset . ,ly:tuplet-number::calc-y-offset)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- text-interface
- tuplet-number-interface))))))
+ (avoid-slur . inside)
+ (cross-staff . ,ly:tuplet-number::calc-cross-staff)
+ (direction . ,tuplet-number::calc-direction)
+ (font-shape . italic)
+ (font-size . -2)
+ (stencil . ,ly:tuplet-number::print)
+ (text . ,tuplet-number::calc-denominator-text)
+ (X-offset . ,ly:tuplet-number::calc-x-offset)
+ (Y-offset . ,ly:tuplet-number::calc-y-offset)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ text-interface
+ tuplet-number-interface))))))
(UnaCordaPedal
. (
- (direction . ,RIGHT)
- (extra-spacing-width . (+inf.0 . -inf.0))
- (font-shape . italic)
- (padding . 0.0) ;; padding relative to UnaCordaPedalLineSpanner
- (self-alignment-X . ,CENTER)
- (stencil . ,ly:text-interface::print)
- (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
- (Y-extent . ,grob::always-Y-extent-from-stencil)
- (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
- (meta . ((class . Item)
- (interfaces . (font-interface
- piano-pedal-script-interface
- self-alignment-interface
- text-interface))))))
+ (direction . ,RIGHT)
+ (extra-spacing-width . (+inf.0 . -inf.0))
+ (font-shape . italic)
+ (padding . 0.0) ;; padding relative to UnaCordaPedalLineSpanner
+ (self-alignment-X . ,CENTER)
+ (stencil . ,ly:text-interface::print)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-stencil)
+ (Y-extent . ,grob::always-Y-extent-from-stencil)
+ (X-offset . ,ly:self-alignment-interface::x-aligned-on-self)
+ (meta . ((class . Item)
+ (interfaces . (font-interface
+ piano-pedal-script-interface
+ self-alignment-interface
+ text-interface))))))
(UnaCordaPedalLineSpanner
. (
- (axes . (,Y))
- (cross-staff . ,ly:side-position-interface::calc-cross-staff)
- (direction . ,DOWN)
- (minimum-space . 1.0)
- (outside-staff-priority . 1000)
- (padding . 1.2)
- (side-axis . ,Y)
- (staff-padding . 1.2)
- (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- piano-pedal-interface
- side-position-interface))))))
+ (axes . (,Y))
+ (cross-staff . ,ly:side-position-interface::calc-cross-staff)
+ (direction . ,DOWN)
+ (minimum-space . 1.0)
+ (outside-staff-priority . 1000)
+ (padding . 1.2)
+ (side-axis . ,Y)
+ (staff-padding . 1.2)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (Y-offset . ,side-position-interface::y-aligned-side)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ piano-pedal-interface
+ side-position-interface))))))
(VaticanaLigature
. (
- (flexa-width . 2.0)
- (stencil . ,ly:vaticana-ligature::print)
- (thickness . 0.6)
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- vaticana-ligature-interface))))))
+ (flexa-width . 2.0)
+ (stencil . ,ly:vaticana-ligature::print)
+ (thickness . 0.6)
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ vaticana-ligature-interface))))))
(VerticalAlignment
. (
- (axes . (,Y))
- (positioning-done . ,ly:align-interface::align-to-ideal-distances)
- (stacking-dir . -1)
- (vertical-skylines . ,ly:axis-group-interface::combine-skylines)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
- (meta . ((class . Spanner)
- (object-callbacks . ((Y-common . ,ly:axis-group-interface::calc-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)
- (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)))
- (interfaces . (align-interface
- axis-group-interface))))))
+ (axes . (,Y))
+ (positioning-done . ,ly:align-interface::align-to-ideal-distances)
+ (stacking-dir . -1)
+ (vertical-skylines . ,ly:axis-group-interface::combine-skylines)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
+ (meta . ((class . Spanner)
+ (object-callbacks . ((Y-common . ,ly:axis-group-interface::calc-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)
+ (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)))
+ (interfaces . (align-interface
+ axis-group-interface))))))
(VerticalAxisGroup
. (
- (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
- (axes . (,Y))
- (default-staff-staff-spacing . ((basic-distance . 9)
- (minimum-distance . 8)
- (padding . 1)))
- (nonstaff-unrelatedstaff-spacing . ((padding . 0.5)))
- (outside-staff-placement-directive . left-to-right-polite)
- (staff-staff-spacing . ,(ly:make-unpure-pure-container ly:axis-group-interface::calc-staff-staff-spacing ly:axis-group-interface::calc-pure-staff-staff-spacing))
- (stencil . ,ly:axis-group-interface::print)
- (skyline-horizontal-padding . 0.1)
- (vertical-skylines . ,ly:hara-kiri-group-spanner::calc-skylines)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,(ly:make-unpure-pure-container ly:hara-kiri-group-spanner::y-extent ly:hara-kiri-group-spanner::pure-height))
- (Y-offset . ,ly:hara-kiri-group-spanner::force-hara-kiri-callback)
- (meta . ((class . Spanner)
- (object-callbacks . (
- (X-common . ,ly:axis-group-interface::calc-x-common)
- (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
-
- (interfaces . (axis-group-interface
- hara-kiri-group-spanner-interface))))))
+ (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights)
+ (axes . (,Y))
+ (default-staff-staff-spacing . ((basic-distance . 9)
+ (minimum-distance . 8)
+ (padding . 1)))
+ (nonstaff-unrelatedstaff-spacing . ((padding . 0.5)))
+ (outside-staff-placement-directive . left-to-right-polite)
+ (staff-staff-spacing . ,(ly:make-unpure-pure-container ly:axis-group-interface::calc-staff-staff-spacing ly:axis-group-interface::calc-pure-staff-staff-spacing))
+ (stencil . ,ly:axis-group-interface::print)
+ (skyline-horizontal-padding . 0.1)
+ (vertical-skylines . ,ly:hara-kiri-group-spanner::calc-skylines)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,(ly:make-unpure-pure-container ly:hara-kiri-group-spanner::y-extent ly:hara-kiri-group-spanner::pure-height))
+ (Y-offset . ,ly:hara-kiri-group-spanner::force-hara-kiri-callback)
+ (meta . ((class . Spanner)
+ (object-callbacks . (
+ (X-common . ,ly:axis-group-interface::calc-x-common)
+ (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+
+ (interfaces . (axis-group-interface
+ hara-kiri-group-spanner-interface))))))
(VoiceFollower
. (
- (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
- (bound-details . ((right . ((attach-dir . ,CENTER)
- (padding . 1.5)
- ))
- (left . ((attach-dir . ,CENTER)
- (padding . 1.5)
- ))
- ))
- (cross-staff . #t)
- (gap . 0.5)
- (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
- (non-musical . #t)
- (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
- (stencil . ,ly:line-spanner::print)
- (style . line)
- (X-extent . #f)
- (Y-extent . #f)
- (meta . ((class . Spanner)
- (interfaces . (line-interface
- line-spanner-interface))))))
+ (after-line-breaking . ,ly:spanner::kill-zero-spanned-time)
+ (bound-details . ((right . ((attach-dir . ,CENTER)
+ (padding . 1.5)
+ ))
+ (left . ((attach-dir . ,CENTER)
+ (padding . 1.5)
+ ))
+ ))
+ (cross-staff . #t)
+ (gap . 0.5)
+ (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
+ (non-musical . #t)
+ (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
+ (stencil . ,ly:line-spanner::print)
+ (style . line)
+ (X-extent . #f)
+ (Y-extent . #f)
+ (meta . ((class . Spanner)
+ (interfaces . (line-interface
+ line-spanner-interface))))))
(VoltaBracket
. (
- (direction . ,UP)
- (edge-height . (2.0 . 2.0)) ;; staff-space;
- (font-encoding . fetaText)
- (font-size . -4)
- (shorten-pair . ,ly:volta-bracket::calc-shorten-pair)
- (stencil . ,ly:volta-bracket-interface::print)
- (thickness . 1.6) ;; line-thickness
- (word-space . 0.6)
- (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
- (Y-extent . ,(grob::unpure-Y-extent-from-stencil volta-bracket-interface::pure-height))
- (meta . ((class . Spanner)
- (interfaces . (font-interface
- horizontal-bracket-interface
- line-interface
- side-position-interface
- text-interface
- volta-bracket-interface
- volta-interface))))))
+ (direction . ,UP)
+ (edge-height . (2.0 . 2.0)) ;; staff-space;
+ (font-encoding . fetaText)
+ (font-size . -4)
+ (shorten-pair . ,ly:volta-bracket::calc-shorten-pair)
+ (stencil . ,ly:volta-bracket-interface::print)
+ (thickness . 1.6) ;; line-thickness
+ (word-space . 0.6)
+ (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil)
+ (Y-extent . ,(grob::unpure-Y-extent-from-stencil volta-bracket-interface::pure-height))
+ (meta . ((class . Spanner)
+ (interfaces . (font-interface
+ horizontal-bracket-interface
+ line-interface
+ side-position-interface
+ text-interface
+ volta-bracket-interface
+ volta-interface))))))
(VoltaBracketSpanner
. (
- (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
- (axes . (,Y))
- (direction . ,UP)
- (no-alignment . #t)
- (outside-staff-priority . 600)
- (padding . 1)
- (side-axis . ,Y)
- (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
- (X-extent . ,ly:axis-group-interface::width)
- (Y-extent . ,axis-group-interface::height)
+ (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff)
+ (axes . (,Y))
+ (direction . ,UP)
+ (no-alignment . #t)
+ (outside-staff-priority . 600)
+ (padding . 1)
+ (side-axis . ,Y)
+ (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils)
+ (X-extent . ,ly:axis-group-interface::width)
+ (Y-extent . ,axis-group-interface::height)
(Y-offset . ,side-position-interface::y-aligned-side)
- (meta . ((class . Spanner)
- (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
- (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
- (interfaces . (axis-group-interface
- side-position-interface
- volta-interface))))))
+ (meta . ((class . Spanner)
+ (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common)
+ (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs)))
+ (interfaces . (axis-group-interface
+ side-position-interface
+ volta-interface))))))
-))
+ ))
(define (completize-grob-entry x)
"Transplant assoc key into 'name entry of 'meta of X. Set interfaces for Item, Spanner etc.
;; (display (car x))
;; (newline)
(let* ((name-sym (car x))
- (grob-entry (cdr x))
- (meta-entry (assoc-get 'meta grob-entry))
- (class (assoc-get 'class meta-entry))
- (ifaces-entry
- (assoc-get 'interfaces meta-entry)))
+ (grob-entry (cdr x))
+ (meta-entry (assoc-get 'meta grob-entry))
+ (class (assoc-get 'class meta-entry))
+ (ifaces-entry
+ (assoc-get 'interfaces meta-entry)))
(cond
((eq? 'Item class)
(set! ifaces-entry (cons 'spanner-interface ifaces-entry)))
((eq? 'Paper_column class)
(set! ifaces-entry (cons 'item-interface
- (cons 'paper-column-interface ifaces-entry))))
+ (cons 'paper-column-interface ifaces-entry))))
((eq? 'System class)
(set! ifaces-entry (cons 'system-interface
- (cons 'spanner-interface ifaces-entry))))
+ (cons 'spanner-interface ifaces-entry))))
(else
(ly:warning "Unknown class ~a" class)))
(set! meta-entry (assoc-set! meta-entry 'name name-sym))
(set! meta-entry (assoc-set! meta-entry 'interfaces
- ifaces-entry))
+ ifaces-entry))
(set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
(cons name-sym grob-entry)))
;; line-length.
(new-off (/ (- line-length corr (* (1+ guess) on)) guess))
)
- (cond
-
- ;; Settings for (= on 0). Resulting in a dotted line.
-
- ;; If line-length isn't shorter than `th´, change the given
- ;; value for `off´ to fit the line-length.
- ((and (= on 0) (< th line-length))
- (set! off new-off))
-
- ;; If the line-length is shorter than `th´, it makes no
- ;; sense to adjust `off´. The rounded edges of the lines
- ;; would prevent any nice output.
- ;; Do nothing.
- ;; This will result in a single dot for very short lines.
- ((and (= on 0) (>= th line-length))
- #f)
-
- ;; Settings for (not (= on 0)). Resulting in a dashed line.
-
- ;; If line-length isn't shorter than one go of on-off-on,
- ;; change the given value for `off´ to fit the line-length.
- ((< (+ (* 2 on) off) line-length)
- (set! off new-off))
- ;; If the line-length is too short, but greater than
- ;; (* 4 th) set on/off to (/ line-length 3)
- ((< (* 4 th) line-length)
- (set! on (/ line-length 3))
- (set! off (/ line-length 3)))
- ;; If the line-length is shorter than (* 4 th), it makes
- ;; no sense trying to adjust on/off. The rounded edges of
- ;; the lines would prevent any nice output.
- ;; Simply set `on´ to line-length.
- (else
- (set! on line-length))))))
+ (cond
+
+ ;; Settings for (= on 0). Resulting in a dotted line.
+
+ ;; If line-length isn't shorter than `th´, change the given
+ ;; value for `off´ to fit the line-length.
+ ((and (= on 0) (< th line-length))
+ (set! off new-off))
+
+ ;; If the line-length is shorter than `th´, it makes no
+ ;; sense to adjust `off´. The rounded edges of the lines
+ ;; would prevent any nice output.
+ ;; Do nothing.
+ ;; This will result in a single dot for very short lines.
+ ((and (= on 0) (>= th line-length))
+ #f)
+
+ ;; Settings for (not (= on 0)). Resulting in a dashed line.
+
+ ;; If line-length isn't shorter than one go of on-off-on,
+ ;; change the given value for `off´ to fit the line-length.
+ ((< (+ (* 2 on) off) line-length)
+ (set! off new-off))
+ ;; If the line-length is too short, but greater than
+ ;; (* 4 th) set on/off to (/ line-length 3)
+ ((< (* 4 th) line-length)
+ (set! on (/ line-length 3))
+ (set! off (/ line-length 3)))
+ ;; If the line-length is shorter than (* 4 th), it makes
+ ;; no sense trying to adjust on/off. The rounded edges of
+ ;; the lines would prevent any nice output.
+ ;; Simply set `on´ to line-length.
+ (else
+ (set! on line-length))))))
;; If `on´ or `off´ is negative, or the sum of `on' and `off' equals zero a
;; ghostscript-error occurs while calling
;; To give the lines produced by \draw-line and \draw-dashed-line the same
;; length, half-thick has to be added to the stencil-extensions.
(ly:make-stencil
- (list 'dashed-line th on off x y phase)
- (interval-widen (ordered-cons 0 x) half-thick)
- (interval-widen (ordered-cons 0 y) half-thick))))
+ (list 'dashed-line th on off x y phase)
+ (interval-widen (ordered-cons 0 x) half-thick)
+ (interval-widen (ordered-cons 0 y) half-thick))))
(define-markup-command (draw-dotted-line layout props dest)
(number-pair?)
@end lilypond"
(let ((new-props (prepend-alist-chain 'on 0
- (prepend-alist-chain 'full-length #t props))))
+ (prepend-alist-chain 'full-length #t props))))
- (interpret-markup layout
- new-props
- (markup #:draw-dashed-line dest))))
+ (interpret-markup layout
+ new-props
+ (markup #:draw-dashed-line dest))))
(define-markup-command (draw-hline layout props)
()
(interpret-markup layout
props
(markup #:draw-line (cons (* line-width
- span-factor)
- 0))))
+ span-factor)
+ 0))))
(define-markup-command (draw-circle layout props radius thickness filled)
(number? number? boolean?)
(boolean?)
#:category graphic
#:properties ((thickness 0.1)
- (font-size 0)
- (baseline-skip 2))
+ (font-size 0)
+ (baseline-skip 2))
"
@cindex drawing triangles within text
,ex 0.0
,(* 0.5 ex)
,(* 0.86 ex))
- ,thickness
- ,filled)
+ ,thickness
+ ,filled)
(cons 0 ex)
(cons 0 (* .86 ex)))))
(markup?)
#:category graphic
#:properties ((thickness 1)
- (font-size 0)
- (circle-padding 0.2))
+ (font-size 0)
+ (circle-padding 0.2))
"
@cindex circling text
@end lilypond"
(let ((th (* (ly:output-def-lookup layout 'line-thickness)
thickness))
- (pad (* (magstep font-size) circle-padding))
- (m (interpret-markup layout props arg)))
+ (pad (* (magstep font-size) circle-padding))
+ (m (interpret-markup layout props arg)))
(circle-stencil m th pad)))
(define-markup-command (with-url layout props url arg)
}
@end lilypond"
(let* ((stil (interpret-markup layout props arg))
- (xextent (ly:stencil-extent stil X))
- (yextent (ly:stencil-extent stil Y))
- (old-expr (ly:stencil-expr stil))
- (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
+ (xextent (ly:stencil-extent stil X))
+ (yextent (ly:stencil-extent stil Y))
+ (old-expr (ly:stencil-expr stil))
+ (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
(ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
}
@end lilypond"
(let* ((stil (interpret-markup layout props arg))
- (xextent (ly:stencil-extent stil X))
- (yextent (ly:stencil-extent stil Y))
- (old-expr (ly:stencil-expr stil))
- (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent))))
+ (xextent (ly:stencil-extent stil X))
+ (yextent (ly:stencil-extent stil Y))
+ (old-expr (ly:stencil-expr stil))
+ (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent))))
(ly:stencil-add (ly:make-stencil link-expr xextent yextent) stil)))
(link-expr (list 'page-link page-number
`(quote ,x-ext) `(quote ,y-ext))))
(ly:stencil-add (ly:make-stencil link-expr x-ext y-ext)
-arg-stencil)))))
+ arg-stencil)))))
x-ext
y-ext)))
}
@end lilypond"
(let* ((y (* slope width))
- (yext (cons (min 0 y) (max 0 y)))
- (half (/ thickness 2)))
+ (yext (cons (min 0 y) (max 0 y)))
+ (half (/ thickness 2)))
(ly:make-stencil
`(polygon ',(list
- 0 (/ thickness -2)
- width (+ (* width slope) (/ thickness -2))
- width (+ (* width slope) (/ thickness 2))
- 0 (/ thickness 2))
- ,(ly:output-def-lookup layout 'blot-diameter)
- #t)
+ 0 (/ thickness -2)
+ width (+ (* width slope) (/ thickness -2))
+ width (+ (* width slope) (/ thickness 2))
+ 0 (/ thickness 2))
+ ,(ly:output-def-lookup layout 'blot-diameter)
+ #t)
(cons 0 width)
(cons (+ (- half) (car yext))
- (+ half (cdr yext))))))
+ (+ half (cdr yext))))))
(define-markup-command (underline layout props arg)
(markup?)
(markup?)
#:category font
#:properties ((thickness 1)
- (font-size 0)
- (box-padding 0.2))
+ (font-size 0)
+ (box-padding 0.2))
"
@cindex enclosing text within a box
(markup?)
#:category graphic
#:properties ((thickness 1)
- (corner-radius 1)
- (font-size 0)
- (box-padding 0.5))
+ (corner-radius 1)
+ (font-size 0)
+ (box-padding 0.5))
"@cindex enclosing text in a box with rounded corners
@cindex drawing boxes with rounded corners around text
Draw a box with rounded corners around @var{arg}. Looks at @code{thickness},
Create a box of the same height as the space in the current font."
(let ((m (ly:text-interface::interpret-markup layout props " ")))
(ly:make-stencil (ly:stencil-expr m)
- '(0 . 0)
- (ly:stencil-extent m X)
- )))
+ '(0 . 0)
+ (ly:stencil-extent m X)
+ )))
(define-markup-command (hspace layout props amount)
(number?)
(ly:make-stencil "" (cons 0 amount) empty-interval))
(define-markup-command (vspace layout props amount)
- (number?)
- #:category align
- "
+ (number?)
+ #:category align
+ "
@cindex creating vertical spaces in text
Create an invisible object taking up vertical space
((match (regexp-exec bbox-regexp string)))
(if match
- (map (lambda (x)
- (string->number (match:substring match x)))
- (cdr (iota 5)))
+ (map (lambda (x)
+ (string->number (match:substring match x)))
+ (cdr (iota 5)))
- #f)))
+ #f)))
(define-markup-command (epsfile layout props axis size file-name)
(number? number? string?)
;; FIXME
(ly:make-stencil
(list 'embedded-ps
- (format #f "
+ (format #f "
gsave currentpoint translate
0.1 setlinewidth
~a
grestore
"
- str))
+ str))
'(0 . 0) '(0 . 0)))
(define-markup-command (path layout props thickness commands) (number? list?)
#:category graphic
#:properties ((line-cap-style 'round)
- (line-join-style 'round)
- (filled #f))
+ (line-join-style 'round)
+ (filled #f))
"
@cindex paths, drawing
@cindex drawing paths
}
@end lilypond"
(let* ((half-thickness (/ thickness 2))
- (current-point '(0 . 0))
- (set-point (lambda (lst) (set! current-point lst)))
- (relative? (lambda (x)
- (string-prefix? "r" (symbol->string (car x)))))
- ;; For calculating extents, we want to modify the command
- ;; list so that all coordinates are absolute.
- (new-commands (map (lambda (x)
- (cond
- ;; for rmoveto, rlineto
- ((and (relative? x) (= 3 (length x)))
- (let ((cp (cons
- (+ (car current-point)
- (second x))
- (+ (cdr current-point)
- (third x)))))
- (set-point cp)
- (list (car cp)
- (cdr cp))))
- ;; for rcurveto
- ((and (relative? x) (= 7 (length x)))
- (let* ((old-cp current-point)
- (cp (cons
- (+ (car old-cp)
- (sixth x))
- (+ (cdr old-cp)
- (seventh x)))))
- (set-point cp)
- (list (+ (car old-cp) (second x))
- (+ (cdr old-cp) (third x))
- (+ (car old-cp) (fourth x))
- (+ (cdr old-cp) (fifth x))
- (car cp)
- (cdr cp))))
- ;; for moveto, lineto
- ((= 3 (length x))
- (set-point (cons (second x)
- (third x)))
- (drop x 1))
- ;; for curveto
- ((= 7 (length x))
- (set-point (cons (sixth x)
- (seventh x)))
- (drop x 1))
- ;; keep closepath for filtering;
- ;; see `without-closepath'.
- (else x)))
- commands))
- ;; path-min-max does not accept 0-arg lists,
- ;; and since closepath does not affect extents, filter
- ;; out those commands here.
- (without-closepath (filter (lambda (x)
- (not (equal? 'closepath (car x))))
- new-commands))
- (extents (path-min-max
- ;; set the origin to the first moveto
- (list (list-ref (car without-closepath) 0)
- (list-ref (car without-closepath) 1))
- without-closepath))
- (X-extent (cons (list-ref extents 0) (list-ref extents 1)))
- (Y-extent (cons (list-ref extents 2) (list-ref extents 3)))
- (command-list (fold-right append '() commands)))
+ (current-point '(0 . 0))
+ (set-point (lambda (lst) (set! current-point lst)))
+ (relative? (lambda (x)
+ (string-prefix? "r" (symbol->string (car x)))))
+ ;; For calculating extents, we want to modify the command
+ ;; list so that all coordinates are absolute.
+ (new-commands (map (lambda (x)
+ (cond
+ ;; for rmoveto, rlineto
+ ((and (relative? x) (= 3 (length x)))
+ (let ((cp (cons
+ (+ (car current-point)
+ (second x))
+ (+ (cdr current-point)
+ (third x)))))
+ (set-point cp)
+ (list (car cp)
+ (cdr cp))))
+ ;; for rcurveto
+ ((and (relative? x) (= 7 (length x)))
+ (let* ((old-cp current-point)
+ (cp (cons
+ (+ (car old-cp)
+ (sixth x))
+ (+ (cdr old-cp)
+ (seventh x)))))
+ (set-point cp)
+ (list (+ (car old-cp) (second x))
+ (+ (cdr old-cp) (third x))
+ (+ (car old-cp) (fourth x))
+ (+ (cdr old-cp) (fifth x))
+ (car cp)
+ (cdr cp))))
+ ;; for moveto, lineto
+ ((= 3 (length x))
+ (set-point (cons (second x)
+ (third x)))
+ (drop x 1))
+ ;; for curveto
+ ((= 7 (length x))
+ (set-point (cons (sixth x)
+ (seventh x)))
+ (drop x 1))
+ ;; keep closepath for filtering;
+ ;; see `without-closepath'.
+ (else x)))
+ commands))
+ ;; path-min-max does not accept 0-arg lists,
+ ;; and since closepath does not affect extents, filter
+ ;; out those commands here.
+ (without-closepath (filter (lambda (x)
+ (not (equal? 'closepath (car x))))
+ new-commands))
+ (extents (path-min-max
+ ;; set the origin to the first moveto
+ (list (list-ref (car without-closepath) 0)
+ (list-ref (car without-closepath) 1))
+ without-closepath))
+ (X-extent (cons (list-ref extents 0) (list-ref extents 1)))
+ (Y-extent (cons (list-ref extents 2) (list-ref extents 3)))
+ (command-list (fold-right append '() commands)))
;; account for line thickness
(set! X-extent (interval-widen X-extent half-thickness))
(set! Y-extent (interval-widen Y-extent half-thickness))
(ly:make-stencil
- `(path ,thickness `(,@',command-list)
- ',line-cap-style ',line-join-style ,filled)
- X-extent
- Y-extent)))
+ `(path ,thickness `(,@',command-list)
+ ',line-cap-style ',line-join-style ,filled)
+ X-extent
+ Y-extent)))
(define-markup-list-command (score-lines layout props score)
(ly:score?)
(- (car (paper-system-staff-extents paper-system)))
Y))
(vector->list (ly:paper-score-paper-systems output)))
- (begin
- (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
+ (begin
+ (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
'()))))
(define-markup-command (score layout props score)
(define (replace-ties tie str)
(if (string-contains str "~")
(let*
- ((half-space (/ word-space 2))
- (parts (string-split str #\~))
- (tie-str (markup #:hspace half-space
- #:musicglyph tie
- #:hspace half-space))
- (joined (list-join parts tie-str)))
+ ((half-space (/ word-space 2))
+ (parts (string-split str #\~))
+ (tie-str (markup #:hspace half-space
+ #:musicglyph tie
+ #:hspace half-space))
+ (joined (list-join parts tie-str)))
(make-concat-markup joined))
str))
(let ((match (match-short str)))
(if (not match)
(make-concat-markup (list
- mkp
- (replace-ties "ties.lyric.default" str)))
+ mkp
+ (replace-ties "ties.lyric.default" str)))
(let ((new-str (match:suffix match))
(new-mkp (make-concat-markup (list
- mkp
- (replace-ties "ties.lyric.default"
- (match:prefix match))
- (replace-ties "ties.lyric.short"
- (match:substring match))))))
- (replace-short new-str new-mkp)))))
+ mkp
+ (replace-ties "ties.lyric.default"
+ (match:prefix match))
+ (replace-ties "ties.lyric.short"
+ (match:substring match))))))
+ (replace-short new-str new-mkp)))))
(interpret-markup layout
props
((= (length text-widths) word-count)
(cons
(- (- (/ line-width (1- word-count)) (car text-widths))
- (/ (car (cdr text-widths)) 2))
+ (/ (car (cdr text-widths)) 2))
(get-fill-space word-count line-width word-space (cdr text-widths))))
;; special case last padding
((= (length text-widths) 2)
(list (- (/ line-width (1- word-count))
- (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
+ (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
(else
(let ((default-padding
(- (/ line-width (1- word-count))
(markup-list?)
#:category align
#:properties ((word-space)
- (text-direction RIGHT))
+ (text-direction RIGHT))
"Put @var{args} in a horizontal line. The property @code{word-space}
determines the space between markups in @var{args}.
(fold-right (lambda (arg result-list)
(let ((result (if (pair? result-list)
(car result-list)
- '())))
+ '())))
(if (and (pair? arg) (eqv? (car arg) simple-markup))
- (set! arg (cadr arg)))
+ (set! arg (cadr arg)))
(if (and (string? result) (string? arg))
(cons (string-append arg result) (cdr result-list))
- (cons arg result-list))))
+ (cons arg result-list))))
'()
arg-list))
(concat-string-args args))))))
(define (wordwrap-stencils stencils
- justify base-space line-width text-dir)
+ justify base-space line-width text-dir)
"Perform simple wordwrap, return stencil of each line."
(define space (if justify
;; justify only stretches lines.
- (* 0.7 base-space)
- base-space))
+ (* 0.7 base-space)
+ base-space))
(define (stencil-space stencil line-start)
(if (ly:stencil-empty? stencil X)
0
X RIGHT stencil)
X))))
(define (take-list width space stencils
- accumulator accumulated-width)
+ accumulator accumulated-width)
"Return (head-list . tail) pair, with head-list fitting into width"
(if (null? stencils)
- (cons accumulator stencils)
- (let* ((first (car stencils))
+ (cons accumulator stencils)
+ (let* ((first (car stencils))
(first-wid (stencil-space first (null? accumulator)))
(newwid (+ (if (or (ly:stencil-empty? first Y)
(ly:stencil-empty? first X))
0 space)
first-wid accumulated-width)))
- (if (or (null? accumulator)
+ (if (or (null? accumulator)
(< newwid width))
(take-list width space
(cdr stencils)
(todo stencils))
(let* ((line-break (take-list line-width space todo
'() 0.0))
- (line-stencils (car line-break))
- (space-left (- line-width
+ (line-stencils (car line-break))
+ (space-left (- line-width
(stencil-space
(stack-stencil-line 0 line-stencils)
#t)))
(line-words (count (lambda (s) (not (or (ly:stencil-empty? s Y)
(ly:stencil-empty? s X))))
line-stencils))
- (line-word-space (cond ((not justify) space)
+ (line-word-space (cond ((not justify) space)
;; don't stretch last line of paragraph.
;; hmmm . bug - will overstretch the last line in some case.
((null? (cdr line-break))
(define-markup-list-command (wordwrap-internal layout props justify args)
(boolean? markup-list?)
#:properties ((line-width #f)
- (word-space)
- (text-direction RIGHT))
+ (word-space)
+ (text-direction RIGHT))
"Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}."
(wordwrap-stencils (interpret-markup-list layout props args)
justify
(markup-list?)
#:category align
#:properties ((baseline-skip)
- wordwrap-internal-markup-list)
+ wordwrap-internal-markup-list)
"
@cindex justifying text
(markup-list?)
#:category align
#:properties ((baseline-skip)
- wordwrap-internal-markup-list)
+ wordwrap-internal-markup-list)
"Simple wordwrap. Use @code{\\override #'(line-width . @var{X})} to set
the line width, where @var{X} is the number of staff spaces.
}
@end lilypond"
(stack-lines DOWN 0.0 baseline-skip
- (wordwrap-internal-markup-list layout props #f args)))
+ (wordwrap-internal-markup-list layout props #f args)))
(define-markup-list-command (wordwrap-string-internal layout props justify arg)
(boolean? string?)
#:properties ((line-width)
- (word-space)
- (text-direction RIGHT))
+ (word-space)
+ (text-direction RIGHT))
"Internal markup list command used to define @code{\\justify-string} and
@code{\\wordwrap-string}."
(let* ((para-strings (regexp-split
(string?)
#:category align
#:properties ((baseline-skip)
- wordwrap-string-internal-markup-list)
+ wordwrap-string-internal-markup-list)
"Wordwrap a string. Paragraphs may be separated with double newlines.
@lilypond[verbatim,quote]
(string?)
#:category align
#:properties ((baseline-skip)
- wordwrap-string-internal-markup-list)
+ wordwrap-string-internal-markup-list)
"Justify a string. Paragraphs may be separated with double newlines
@lilypond[verbatim,quote]
}
@end lilypond"
(let* ((s1 (interpret-markup layout props arg1))
- (s2 (interpret-markup layout props arg2)))
+ (s2 (interpret-markup layout props arg2)))
(ly:stencil-add s1 s2)))
;;
(markup-list?)
#:category align
#:properties ((direction)
- (baseline-skip))
+ (baseline-skip))
"
@cindex changing direction of text columns
(markup-list?)
#:category align
#:properties ((baseline-skip))
- "
+ "
@cindex text columns, left-aligned
Put @code{args} in a left-aligned column.
(markup-list?)
#:category align
#:properties ((baseline-skip))
- "
+ "
@cindex text columns, right-aligned
Put @code{args} in a right-aligned column.
@var{procedure} should take a single argument."
(let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
(set-object-property! anonymous-with-signature
- 'markup-signature
- (list markup?))
+ 'markup-signature
+ (list markup?))
(interpret-markup layout props (list anonymous-with-signature arg))))
(define-markup-command (footnote layout props mkup note)
@end lilypond
The footnote will not be annotated automatically."
(ly:stencil-combine-at-edge
- (interpret-markup layout props mkup)
- X
- RIGHT
- (ly:make-stencil
- `(footnote (gensym "footnote") #f ,(interpret-markup layout props note))
- '(0 . 0)
- '(0 . 0))
- 0.0))
+ (interpret-markup layout props mkup)
+ X
+ RIGHT
+ (ly:make-stencil
+ `(footnote (gensym "footnote") #f ,(interpret-markup layout props note))
+ '(0 . 0)
+ '(0 . 0))
+ 0.0))
(define-markup-command (auto-footnote layout props mkup note)
(markup? markup?)
(footnote-hash (gensym "footnote"))
(stencil-seed 0)
(gauge-stencil (interpret-markup
+ layout
+ props
+ ((ly:output-def-lookup
layout
- props
- ((ly:output-def-lookup
- layout
- 'footnote-numbering-function)
- stencil-seed)))
+ 'footnote-numbering-function)
+ stencil-seed)))
(x-ext (ly:stencil-extent gauge-stencil X))
- (y-ext (ly:stencil-extent gauge-stencil Y))
+ (y-ext (ly:stencil-extent gauge-stencil Y))
(footnote-number
- `(delay-stencil-evaluation
- ,(delay
- (ly:stencil-expr
- (let* ((table
- (ly:output-def-lookup layout
- 'number-footnote-table))
- (footnote-stencil (if (list? table)
- (assoc-get footnote-hash
- table)
- empty-stencil))
- (footnote-stencil (if (ly:stencil? footnote-stencil)
- footnote-stencil
- (begin
- (ly:programming-error
-"Cannot find correct footnote for a markup object.")
- empty-stencil)))
- (gap (- (interval-length x-ext)
- (interval-length
- (ly:stencil-extent footnote-stencil X))))
- (y-trans (- (+ (cdr y-ext)
- raise)
- (cdr (ly:stencil-extent footnote-stencil
- Y)))))
- (ly:stencil-translate footnote-stencil
- (cons gap y-trans)))))))
+ `(delay-stencil-evaluation
+ ,(delay
+ (ly:stencil-expr
+ (let* ((table
+ (ly:output-def-lookup layout
+ 'number-footnote-table))
+ (footnote-stencil (if (list? table)
+ (assoc-get footnote-hash
+ table)
+ empty-stencil))
+ (footnote-stencil (if (ly:stencil? footnote-stencil)
+ footnote-stencil
+ (begin
+ (ly:programming-error
+ "Cannot find correct footnote for a markup object.")
+ empty-stencil)))
+ (gap (- (interval-length x-ext)
+ (interval-length
+ (ly:stencil-extent footnote-stencil X))))
+ (y-trans (- (+ (cdr y-ext)
+ raise)
+ (cdr (ly:stencil-extent footnote-stencil
+ Y)))))
+ (ly:stencil-translate footnote-stencil
+ (cons gap y-trans)))))))
(main-stencil (ly:stencil-combine-at-edge
- markup-stencil
- X
- RIGHT
- (ly:make-stencil footnote-number x-ext y-ext)
- padding)))
- (ly:stencil-add
- main-stencil
- (ly:make-stencil
+ markup-stencil
+ X
+ RIGHT
+ (ly:make-stencil footnote-number x-ext y-ext)
+ padding)))
+ (ly:stencil-add
+ main-stencil
+ (ly:make-stencil
`(footnote ,footnote-hash #t ,(interpret-markup layout props note))
'(0 . 0)
'(0 . 0)))))
}
@end lilypond"
(interpret-markup layout props
- `(,fontsize-markup -1 ,arg)))
+ `(,fontsize-markup -1 ,arg)))
(define-markup-command (larger layout props arg)
(markup?)
}
@end lilypond"
(interpret-markup layout props
- `(,fontsize-markup 1 ,arg)))
+ `(,fontsize-markup 1 ,arg)))
(define-markup-command (finger layout props arg)
(markup?)
(ref-word-space (chain-assoc-get 'word-space text-props 0.6))
(ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
(magnification (/ size ref-size)))
- (interpret-markup
- layout
- (cons
- `((baseline-skip . ,(* magnification ref-baseline))
- (word-space . ,(* magnification ref-word-space))
- (font-size . ,(magnification->font-size magnification)))
- props)
- arg)))
+ (interpret-markup
+ layout
+ (cons
+ `((baseline-skip . ,(* magnification ref-baseline))
+ (word-space . ,(* magnification ref-word-space))
+ (font-size . ,(magnification->font-size magnification)))
+ props)
+ arg)))
(define-markup-command (fontsize layout props increment arg)
(number? markup?)
#:category font
#:properties ((font-size 0)
- (word-space 1)
- (baseline-skip 2))
+ (word-space 1)
+ (baseline-skip 2))
"Add @var{increment} to the font-size. Adjusts @code{baseline-skip}
accordingly.
(define (char-list->markup chars lower)
(let ((final-string (string-upcase (reverse-list->string chars))))
(if lower
- (markup #:fontsize -2 final-string)
- final-string)))
+ (markup #:fontsize -2 final-string)
+ final-string)))
(define (make-small-caps rest-chars currents current-is-lower prev-result)
(if (null? rest-chars)
- (make-concat-markup
- (reverse! (cons (char-list->markup currents current-is-lower)
- prev-result)))
- (let* ((ch (car rest-chars))
- (is-lower (char-lower-case? ch)))
- (if (or (and current-is-lower is-lower)
- (and (not current-is-lower) (not is-lower)))
- (make-small-caps (cdr rest-chars)
- (cons ch currents)
- is-lower
- prev-result)
- (make-small-caps (cdr rest-chars)
- (list ch)
- is-lower
- (if (null? currents)
- prev-result
- (cons (char-list->markup
- currents current-is-lower)
- prev-result)))))))
+ (make-concat-markup
+ (reverse! (cons (char-list->markup currents current-is-lower)
+ prev-result)))
+ (let* ((ch (car rest-chars))
+ (is-lower (char-lower-case? ch)))
+ (if (or (and current-is-lower is-lower)
+ (and (not current-is-lower) (not is-lower)))
+ (make-small-caps (cdr rest-chars)
+ (cons ch currents)
+ is-lower
+ prev-result)
+ (make-small-caps (cdr rest-chars)
+ (list ch)
+ is-lower
+ (if (null? currents)
+ prev-result
+ (cons (char-list->markup
+ currents current-is-lower)
+ prev-result)))))))
(interpret-markup layout props
- (if (string? arg)
- (make-small-caps (string->list arg) (list) #f (list))
- arg)))
+ (if (string? arg)
+ (make-small-caps (string->list arg) (list) #f (list))
+ arg)))
(define-markup-command (caps layout props arg)
(markup?)
;; ugh - latin1
(interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
- arg))
+ arg))
(define-markup-command (italic layout props arg)
(markup?)
}
@end lilypond"
(interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
- arg))
+ arg))
(define-markup-command (normal-text layout props arg)
(markup?)
;; ugh - latin1
(interpret-markup layout
(cons '((font-family . roman) (font-shape . upright)
- (font-series . medium) (font-encoding . latin1))
- props)
+ (font-series . medium) (font-encoding . latin1))
+ props)
arg))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
}
@end lilypond"
(let* ((font (ly:paper-get-font layout
- (cons '((font-encoding . fetaMusic)
- (font-name . #f))
+ (cons '((font-encoding . fetaMusic)
+ (font-name . #f))
- props)))
- (glyph (ly:font-get-glyph font glyph-name)))
+ props)))
+ (glyph (ly:font-get-glyph font glyph-name)))
(if (null? (ly:stencil-expr glyph))
- (ly:warning (_ "Cannot find glyph ~a") glyph-name))
+ (ly:warning (_ "Cannot find glyph ~a") glyph-name))
glyph))
@end lilypond"
(let ((stil (interpret-markup layout props arg)))
(ly:make-stencil (list 'color color (ly:stencil-expr stil))
- (ly:stencil-extent stil X)
- (ly:stencil-extent stil Y))))
+ (ly:stencil-extent stil X)
+ (ly:stencil-extent stil Y))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; glyphs
@end lilypond"
(let*
((name (format #f "arrowheads.~a.~a~a"
- (if filled
- "close"
- "open")
- axis
- dir)))
+ (if filled
+ "close"
+ "open")
+ axis
+ dir)))
(ly:font-get-glyph
(ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
- props))
+ props))
name)))
(define-markup-command (lookup layout props glyph-name)
}
@end lilypond"
(ly:font-get-glyph (ly:paper-get-font layout props)
- glyph-name))
+ glyph-name))
(define-markup-command (char layout props num)
(integer?)
(integer->char (+ i (char->integer #\A)))))
(define number->mark-alphabet-vector (list->vector
- (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
+ (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
(define (number->markletter-string vec n)
"Double letters for big marks."
(let* ((lst (vector-length vec)))
(if (>= n lst)
- (string-append (number->markletter-string vec (1- (quotient n lst)))
- (number->markletter-string vec (remainder n lst)))
- (make-string 1 (vector-ref vec n)))))
+ (string-append (number->markletter-string vec (1- (quotient n lst)))
+ (number->markletter-string vec (remainder n lst)))
+ (make-string 1 (vector-ref vec n)))))
(define-markup-command (markletter layout props num)
(integer?)
}
@end lilypond"
(ly:text-interface::interpret-markup layout props
- (number->markletter-string number->mark-letter-vector num)))
+ (number->markletter-string number->mark-letter-vector num)))
(define-markup-command (markalphabet layout props num)
(integer?)
#:category other
- "Make a markup letter for @var{num}. The letters start with A to@tie{}Z
+ "Make a markup letter for @var{num}. The letters start with A to@tie{}Z
and continue with double letters.
@lilypond[verbatim,quote]
\\markalphabet #26
}
@end lilypond"
- (ly:text-interface::interpret-markup layout props
- (number->markletter-string number->mark-alphabet-vector num)))
+ (ly:text-interface::interpret-markup layout props
+ (number->markletter-string number->mark-alphabet-vector num)))
(define-public (horizontal-slash-interval num forward number-interval mag)
(if forward
- (cond ;; ((= num 6) (interval-widen number-interval (* mag 0.5)))
- ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
- (else (interval-widen number-interval (* mag 0.25))))
- (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
- ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
- (else (interval-widen number-interval (* mag 0.25))))
- ))
+ (cond ;; ((= num 6) (interval-widen number-interval (* mag 0.5)))
+ ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
+ (else (interval-widen number-interval (* mag 0.25))))
+ (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
+ ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
+ (else (interval-widen number-interval (* mag 0.25))))
+ ))
(define-public (adjust-slash-stencil num forward stencil mag)
(if forward
- (cond ((= num 2)
- (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
- ((= num 3)
- (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
- ;; ((= num 5)
- ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
- ;; ((= num 7)
- ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
- (else stencil))
- (cond ((= num 6)
- (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
- ;; ((= num 8)
- ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
- (else stencil))
+ (cond ((= num 2)
+ (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
+ ((= num 3)
+ (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
+ ;; ((= num 5)
+ ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
+ ;; ((= num 7)
+ ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
+ (else stencil))
+ (cond ((= num 6)
+ (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
+ ;; ((= num 8)
+ ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
+ (else stencil))
+ )
)
-)
(define (slashed-digit-internal layout props num forward font-size thickness)
(let* ((mag (magstep font-size))
(is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
(slash-stencil (if is-sane
(make-line-stencil thickness
- (car num-x) (- (interval-center num-y) dy)
- (cdr num-x) (+ (interval-center num-y) dy))
+ (car num-x) (- (interval-center num-y) dy)
+ (cdr num-x) (+ (interval-center num-y) dy))
#f)))
(if (ly:stencil? slash-stencil)
- (begin
- ;; for some numbers we need to shift the slash/backslash up or
- ;; down to make the slashed digit look better
- (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
- (set! number-stencil
- (ly:stencil-add number-stencil slash-stencil)))
- (ly:warning "Unable to create slashed digit ~a" num))
+ (begin
+ ;; for some numbers we need to shift the slash/backslash up or
+ ;; down to make the slashed digit look better
+ (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
+ (set! number-stencil
+ (ly:stencil-add number-stencil slash-stencil)))
+ (ly:warning "Unable to create slashed digit ~a" num))
number-stencil))
(integer?)
#:category other
#:properties ((font-size 0)
- (thickness 1.6))
+ (thickness 1.6))
"
@cindex slashed digits
(integer?)
#:category other
#:properties ((font-size 0)
- (thickness 1.6))
+ (thickness 1.6))
"
@cindex backslashed digits
\\markup { \\eyeglasses }
@end lilypond"
(interpret-markup layout props
- (make-override-markup '(line-cap-style . butt)
- (make-path-markup 0.15 eyeglassespath))))
+ (make-override-markup '(line-cap-style . butt)
+ (make-path-markup 0.15 eyeglassespath))))
(define-markup-command (left-brace layout props size)
(number?)
(cons '((font-encoding . fetaBraces)
(font-name . #f))
props)))
- (glyph-count (1- (ly:otf-glyph-count font)))
+ (glyph-count (1- (ly:otf-glyph-count font)))
(scale (ly:output-def-lookup layout 'output-scale))
(scaled-size (/ (ly:pt size) scale))
(glyph (lambda (n)
(ly:font-get-glyph font (string-append "brace"
- (number->string n)))))
- (get-y-from-brace (lambda (brace)
- (interval-length
- (ly:stencil-extent (glyph brace) Y))))
+ (number->string n)))))
+ (get-y-from-brace (lambda (brace)
+ (interval-length
+ (ly:stencil-extent (glyph brace) Y))))
(find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size))
(glyph-found (glyph find-brace)))
(if (or (null? (ly:stencil-expr glyph-found))
- (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y)))
- (> scaled-size (interval-length
- (ly:stencil-extent (glyph glyph-count) Y))))
+ (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y)))
+ (> scaled-size (interval-length
+ (ly:stencil-extent (glyph glyph-count) Y))))
(begin
(ly:warning (_ "no brace found for point size ~S ") size)
(ly:warning (_ "defaulting to ~S pt")
- (/ (* scale (interval-length
- (ly:stencil-extent glyph-found Y)))
- (ly:pt 1)))))
+ (/ (* scale (interval-length
+ (ly:stencil-extent glyph-found Y)))
+ (ly:pt 1)))))
glyph-found))
(define-markup-command (right-brace layout props size)
@end lilypond"
(define (get-glyph-name-candidates dir log style)
(map (lambda (dir-name)
- (format #f "noteheads.~a~a" dir-name
- (if (and (symbol? style)
- (not (equal? 'default style)))
- (select-head-glyph style (min log 2))
- (min log 2))))
- (list (if (= dir UP) "u" "d")
- "s")))
+ (format #f "noteheads.~a~a" dir-name
+ (if (and (symbol? style)
+ (not (equal? 'default style)))
+ (select-head-glyph style (min log 2))
+ (min log 2))))
+ (list (if (= dir UP) "u" "d")
+ "s")))
(define (get-glyph-name font cands)
(if (null? cands)
- ""
- (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
- (get-glyph-name font (cdr cands))
- (car cands))))
+ ""
+ (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
+ (get-glyph-name font (cdr cands))
+ (car cands))))
(define (buildflags flag-stencil remain curr-stencil spacing)
- ;; Function to recursively create a stencil with @code{remain} flags
- ;; from the single-flag stencil @code{curr-stencil}, which is already
- ;; translated to the position of the previous flag position.
- ;;
- ;; Copy and paste from /scm/flag-styles.scm
+ ;; Function to recursively create a stencil with @code{remain} flags
+ ;; from the single-flag stencil @code{curr-stencil}, which is already
+ ;; translated to the position of the previous flag position.
+ ;;
+ ;; Copy and paste from /scm/flag-styles.scm
(if (> remain 0)
(let* ((translated-stencil
- (ly:stencil-translate-axis curr-stencil spacing Y))
+ (ly:stencil-translate-axis curr-stencil spacing Y))
(new-stencil (ly:stencil-add flag-stencil translated-stencil)))
(buildflags new-stencil (- remain 1) translated-stencil spacing))
flag-stencil))
(define (straight-flag-mrkp flag-thickness flag-spacing
- upflag-angle upflag-length
- downflag-angle downflag-length
- dir)
- ;; Create a stencil for a straight flag. @var{flag-thickness} and
- ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and
- ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and
- ;; @var{downflag-length} are given in staff spaces.
- ;;
- ;; All lengths are scaled according to the font size of the note.
- ;;
- ;; From /scm/flag-styles.scm, modified to fit here.
-
- (let* ((stem-up (> dir 0))
- ;; scale with the note size
- (factor (magstep font-size))
- (stem-thickness (* factor 0.1))
- (line-thickness (ly:output-def-lookup layout 'line-thickness))
- (half-stem-thickness (/ (* stem-thickness line-thickness) 2))
- (raw-length (if stem-up upflag-length downflag-length))
- (angle (if stem-up upflag-angle downflag-angle))
- (flag-length (+ (* raw-length factor) half-stem-thickness))
- (flag-end (polar->rectangular flag-length angle))
- (thickness (* flag-thickness factor))
- (thickness-offset (cons 0 (* -1 thickness dir)))
- (spacing (* -1 flag-spacing factor dir))
- (start (cons (- half-stem-thickness) (* half-stem-thickness dir)))
- ;; The points of a round-filled-polygon need to be given in
- ;; clockwise order, otherwise the polygon will be enlarged by
- ;; blot-size*2!
- (points (if stem-up (list start flag-end
- (offset-add flag-end thickness-offset)
- (offset-add start thickness-offset))
- (list start
- (offset-add start thickness-offset)
- (offset-add flag-end thickness-offset)
- flag-end)))
- (stencil (ly:round-filled-polygon points half-stem-thickness))
- ;; Log for 1/8 is 3, so we need to subtract 3
- (flag-stencil (buildflags stencil (- log 3) stencil spacing)))
- flag-stencil))
+ upflag-angle upflag-length
+ downflag-angle downflag-length
+ dir)
+ ;; Create a stencil for a straight flag. @var{flag-thickness} and
+ ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and
+ ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and
+ ;; @var{downflag-length} are given in staff spaces.
+ ;;
+ ;; All lengths are scaled according to the font size of the note.
+ ;;
+ ;; From /scm/flag-styles.scm, modified to fit here.
+
+ (let* ((stem-up (> dir 0))
+ ;; scale with the note size
+ (factor (magstep font-size))
+ (stem-thickness (* factor 0.1))
+ (line-thickness (ly:output-def-lookup layout 'line-thickness))
+ (half-stem-thickness (/ (* stem-thickness line-thickness) 2))
+ (raw-length (if stem-up upflag-length downflag-length))
+ (angle (if stem-up upflag-angle downflag-angle))
+ (flag-length (+ (* raw-length factor) half-stem-thickness))
+ (flag-end (polar->rectangular flag-length angle))
+ (thickness (* flag-thickness factor))
+ (thickness-offset (cons 0 (* -1 thickness dir)))
+ (spacing (* -1 flag-spacing factor dir))
+ (start (cons (- half-stem-thickness) (* half-stem-thickness dir)))
+ ;; The points of a round-filled-polygon need to be given in
+ ;; clockwise order, otherwise the polygon will be enlarged by
+ ;; blot-size*2!
+ (points (if stem-up (list start flag-end
+ (offset-add flag-end thickness-offset)
+ (offset-add start thickness-offset))
+ (list start
+ (offset-add start thickness-offset)
+ (offset-add flag-end thickness-offset)
+ flag-end)))
+ (stencil (ly:round-filled-polygon points half-stem-thickness))
+ ;; Log for 1/8 is 3, so we need to subtract 3
+ (flag-stencil (buildflags stencil (- log 3) stencil spacing)))
+ flag-stencil))
(let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
- props)))
+ props)))
(size-factor (magstep font-size))
(blot (ly:output-def-lookup layout 'blot-diameter))
(head-glyph-name
- (let ((result (get-glyph-name font
- (get-glyph-name-candidates
- (sign dir) log style))))
- (if (string-null? result)
- ;; If no glyph name can be found, select default heads.
- ;; Though this usually means an unsupported style has been
- ;; chosen, it also prevents unrelated 'style settings from
- ;; other grobs (e.g., TextSpanner and TimeSignature) leaking
- ;; into markup.
- (get-glyph-name font
- (get-glyph-name-candidates
- (sign dir) log 'default))
- result)))
+ (let ((result (get-glyph-name font
+ (get-glyph-name-candidates
+ (sign dir) log style))))
+ (if (string-null? result)
+ ;; If no glyph name can be found, select default heads.
+ ;; Though this usually means an unsupported style has been
+ ;; chosen, it also prevents unrelated 'style settings from
+ ;; other grobs (e.g., TextSpanner and TimeSignature) leaking
+ ;; into markup.
+ (get-glyph-name font
+ (get-glyph-name-candidates
+ (sign dir) log 'default))
+ result)))
(head-glyph (ly:font-get-glyph font head-glyph-name))
(ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural)))
(attach-indices (ly:note-head::stem-attachment font head-glyph-name))
(stem-thickness (* size-factor (if ancient-flags? 0.1 0.13)))
(stemy (* dir stem-length))
(attach-off (cons (interval-index
- (ly:stencil-extent head-glyph X)
- (* (sign dir) (car attach-indices)))
+ (ly:stencil-extent head-glyph X)
+ (* (sign dir) (car attach-indices)))
;; fixme, this is inconsistent between X & Y.
(* (sign dir)
(interval-index
(stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0))
(stem-glyph (and (> log 0)
(ly:round-filled-box
- (ordered-cons (+ stem-X-corr (car attach-off))
- (+ stem-X-corr (car attach-off)
- (* (- (sign dir)) stem-thickness)))
- (cons (min stemy (cdr attach-off))
- (max stemy (cdr attach-off)))
- (/ stem-thickness 3))))
+ (ordered-cons (+ stem-X-corr (car attach-off))
+ (+ stem-X-corr (car attach-off)
+ (* (- (sign dir)) stem-thickness)))
+ (cons (min stemy (cdr attach-off))
+ (max stemy (cdr attach-off)))
+ (/ stem-thickness 3))))
(dot (ly:font-get-glyph font "dots.dot"))
(dotwid (interval-length (ly:stencil-extent dot X)))
(dots (and (> dot-count 0)
0))
(flaggl (and (> log 2)
(ly:stencil-translate
- (cond ((eq? flag-style 'modern-straight-flag)
- modern-straight-flag)
- ((eq? flag-style 'old-straight-flag)
- old-straight-flag)
- (else
- (ly:font-get-glyph font
- (format #f (if ancient-flags?
- "flags.mensural~a2~a"
- "flags.~a~a")
- (if (> dir 0) "u" "d")
- log))))
- (cons (+ (car attach-off)
- ;; For tighter stems (with ancient-flags) the
- ;; flag has to be adjusted different.
- (if (and (not ancient-flags?) (< dir 0))
- stem-thickness
- 0))
- (+ stemy flag-style-Y-corr))))))
+ (cond ((eq? flag-style 'modern-straight-flag)
+ modern-straight-flag)
+ ((eq? flag-style 'old-straight-flag)
+ old-straight-flag)
+ (else
+ (ly:font-get-glyph font
+ (format #f (if ancient-flags?
+ "flags.mensural~a2~a"
+ "flags.~a~a")
+ (if (> dir 0) "u" "d")
+ log))))
+ (cons (+ (car attach-off)
+ ;; For tighter stems (with ancient-flags) the
+ ;; flag has to be adjusted different.
+ (if (and (not ancient-flags?) (< dir 0))
+ stem-thickness
+ 0))
+ (+ stemy flag-style-Y-corr))))))
;; If there is a flag on an upstem and the stem is short, move the dots
;; to avoid the flag. 16th notes get a special case because their flags
;; hang lower than any other flags.
;; Not with ancient flags or straight-flags.
(if (and dots (> dir 0) (> log 2)
- (or (eq? flag-style 'default) (null? flag-style))
- (not ancient-flags?)
- (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
- (set! dots (ly:stencil-translate-axis dots 0.5 X)))
+ (or (eq? flag-style 'default) (null? flag-style))
+ (not ancient-flags?)
+ (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
+ (set! dots (ly:stencil-translate-axis dots 0.5 X)))
(if flaggl
(set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
(if (ly:stencil? stem-glyph)
(if (ly:stencil? dots)
(set! stem-glyph
(ly:stencil-add
- (ly:stencil-translate-axis
- dots
- (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
- X)
- stem-glyph)))
+ (ly:stencil-translate-axis
+ dots
+ (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
+ X)
+ stem-glyph)))
stem-glyph))
(define-public log2
;; If no glyph exists, select others for the specified styles
;; otherwise defaulting.
(style-strg
- (cond (
+ (cond (
;; 'baroque needs to be special-cased, otherwise
;; `select-head-glyph´ would catch neomensural-glyphs for
;; this style, if (< log 0).
(eq? style 'baroque)
- (string-append (number->string log) ""))
- ((eq? style 'petrucci)
- (string-append (number->string log) "mensural"))
- ;; In other cases `select-head-glyph´ from output-lib.scm
- ;; works for rest-glyphs, too.
- ((and (symbol? style) (not (eq? style 'default)))
- (select-head-glyph style log))
- (else log)))
+ (string-append (number->string log) ""))
+ ((eq? style 'petrucci)
+ (string-append (number->string log) "mensural"))
+ ;; In other cases `select-head-glyph´ from output-lib.scm
+ ;; works for rest-glyphs, too.
+ ((and (symbol? style) (not (eq? style 'default)))
+ (select-head-glyph style log))
+ (else log)))
;; Choose ledgered glyphs for whole and half rest.
;; Except for the specified styles, logs and MultiMeasureRests.
(ledger-style-rests
- (if (and (or (list? style)
- (not (member style
- '(neomensural mensural petrucci))))
- (not multi-measure-rest)
- (or (= log 0) (= log 1)))
+ (if (and (or (list? style)
+ (not (member style
+ '(neomensural mensural petrucci))))
+ (not multi-measure-rest)
+ (or (= log 0) (= log 1)))
"o"
"")))
(format #f "rests.~a~a" style-strg ledger-style-rests)))
(define (get-glyph-name font cands)
- (if (ly:stencil-empty? (ly:font-get-glyph font cands))
+ (if (ly:stencil-empty? (ly:font-get-glyph font cands))
""
cands))
(let* ((font
- (ly:paper-get-font layout
- (cons '((font-encoding . fetaMusic)) props)))
+ (ly:paper-get-font layout
+ (cons '((font-encoding . fetaMusic)) props)))
(rest-glyph-name
- (let ((result
- (get-glyph-name font
- (get-glyph-name-candidates log style))))
- (if (string-null? result)
+ (let ((result
+ (get-glyph-name font
+ (get-glyph-name-candidates log style))))
+ (if (string-null? result)
;; If no glyph name can be found, select default rests. Though
;; this usually means an unsupported style has been chosen, it
;; also prevents unrelated 'style settings from other grobs
(< log 2)
(>= log 0)
(not (member style '(neomensural mensural petrucci))))
- (set! dots (ly:stencil-translate-axis dots dot-width X)))
+ (set! dots (ly:stencil-translate-axis dots dot-width X)))
;; Add dots to the rest-glyph.
;;
(set! rest-glyph
(ly:stencil-add
(ly:stencil-translate
- dots
- (cons
- (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width)
- (if (< log 2)
- (interval-center (ly:stencil-extent rest-glyph Y))
- (- (interval-end (ly:stencil-extent rest-glyph Y))
- (/ (* 2 dot-width) 3)))))
+ dots
+ (cons
+ (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width)
+ (if (< log 2)
+ (interval-center (ly:stencil-extent rest-glyph Y))
+ (- (interval-end (ly:stencil-extent rest-glyph Y))
+ (/ (* 2 dot-width) 3)))))
rest-glyph)))
rest-glyph))
;; Store them in a list.
;; example: (mmr-numbers 25) -> '(3 0 0 1)
(define (mmr-numbers nmbr)
- (let* ((8-bar-glyph (floor (/ nmbr 8)))
- (8-remainder (remainder nmbr 8))
- (4-bar-glyph (floor (/ 8-remainder 4)))
- (4-remainder (remainder nmbr 4))
- (2-bar-glyph (floor (/ 4-remainder 2)))
- (2-remainder (remainder 4-remainder 2))
- (1-bar-glyph (floor (/ 2-remainder 1))))
- (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph)))
+ (let* ((8-bar-glyph (floor (/ nmbr 8)))
+ (8-remainder (remainder nmbr 8))
+ (4-bar-glyph (floor (/ 8-remainder 4)))
+ (4-remainder (remainder nmbr 4))
+ (2-bar-glyph (floor (/ 4-remainder 2)))
+ (2-remainder (remainder 4-remainder 2))
+ (1-bar-glyph (floor (/ 2-remainder 1))))
+ (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph)))
;; Get the correct mmr-glyphs.
;; Store them in a list.
;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0"))
;; -> ("rests.M3" "rests.M1")
(define (get-mmr-glyphs lst1 lst2)
- (define (helper l1 l2 l3)
- (if (null? l1)
- (reverse l3)
- (helper (cdr l1)
- (cdr l2)
- (append (make-list (car l1) (car l2)) l3))))
- (helper lst1 lst2 '()))
+ (define (helper l1 l2 l3)
+ (if (null? l1)
+ (reverse l3)
+ (helper (cdr l1)
+ (cdr l2)
+ (append (make-list (car l1) (car l2)) l3))))
+ (helper lst1 lst2 '()))
;; If duration is not valid, print a warning and return empty-stencil
(if (or (and (not (integer? (car (parse-simple-duration duration))))
(not multi-measure-rest))
(and (= (string-length (car (string-split duration #\. ))) 1)
(= (string->number (car (string-split duration #\. ))) 0)))
- (begin
- (ly:warning (_ "not a valid duration string: ~a - ignoring") duration)
- empty-stencil)
- (let* (
- ;; For simple rests:
- ;; Get a (log dots) list.
- (parsed (parse-simple-duration duration))
- ;; Create the rest-stencil
- (stil
+ (begin
+ (ly:warning (_ "not a valid duration string: ~a - ignoring") duration)
+ empty-stencil)
+ (let* (
+ ;; For simple rests:
+ ;; Get a (log dots) list.
+ (parsed (parse-simple-duration duration))
+ ;; Create the rest-stencil
+ (stil
(rest-by-number-markup layout props (car parsed) (cadr parsed)))
- ;; For MultiMeasureRests:
- ;; Get the duration-part of duration
- (dur-part-string (car (string-split duration #\. )))
- ;; Get the duration of MMR:
- ;; If not a number (eg. "maxima") calculate it.
- (mmr-duration
- (or (string->number dur-part-string) (expt 2 (abs (car parsed)))))
- ;; Get a list of the correct number of each mmr-glyph.
- (count-mmr-glyphs-list (mmr-numbers mmr-duration))
- ;; Create a list of mmr-stencils,
- ;; translating the glyph for a whole rest.
- (mmr-stils-list
+ ;; For MultiMeasureRests:
+ ;; Get the duration-part of duration
+ (dur-part-string (car (string-split duration #\. )))
+ ;; Get the duration of MMR:
+ ;; If not a number (eg. "maxima") calculate it.
+ (mmr-duration
+ (or (string->number dur-part-string) (expt 2 (abs (car parsed)))))
+ ;; Get a list of the correct number of each mmr-glyph.
+ (count-mmr-glyphs-list (mmr-numbers mmr-duration))
+ ;; Create a list of mmr-stencils,
+ ;; translating the glyph for a whole rest.
+ (mmr-stils-list
(map
- (lambda (x)
- (let ((single-mmr-stil
- (rest-by-number-markup layout props (* -1 x) 0)))
- (if (= x 0)
- (ly:stencil-translate-axis
- single-mmr-stil
- ;; Ugh, hard-coded, why 1?
- 1
- Y)
- single-mmr-stil)))
- (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4)))))
- ;; Adjust the space between the mmr-glyphs,
- ;; if not default-glyphs are used.
- (word-space (if (member style
- '(neomensural mensural petrucci))
- (/ (* word-space 2) 3)
- word-space))
- ;; Create the final mmr-stencil
- ;; via `stack-stencil-line´ from /scm/markup.scm
- (mmr-stil (stack-stencil-line word-space mmr-stils-list)))
-
- ;; Print the number above a multi-measure-rest
- ;; Depends on duration, style and multi-measure-rest-number set #t
- (if (and multi-measure-rest
- multi-measure-rest-number
- (> mmr-duration 1)
- (not (member style '(neomensural mensural petrucci))))
- (let* ((mmr-stil-x-center
- (interval-center (ly:stencil-extent mmr-stil X)))
- (duration-markup
- (markup
- #:fontsize -2
- #:override '(font-encoding . fetaText)
- (number->string mmr-duration)))
- (mmr-number-stil
- (interpret-markup layout props duration-markup))
- (mmr-number-stil-x-center
- (interval-center (ly:stencil-extent mmr-number-stil X))))
-
- (set! mmr-stil (ly:stencil-combine-at-edge
- mmr-stil
- Y UP
- (ly:stencil-translate-axis
- mmr-number-stil
- (- mmr-stil-x-center mmr-number-stil-x-center)
- X)
- ;; Ugh, hardcoded
- 0.8))))
- (if multi-measure-rest
- mmr-stil
- stil))))
+ (lambda (x)
+ (let ((single-mmr-stil
+ (rest-by-number-markup layout props (* -1 x) 0)))
+ (if (= x 0)
+ (ly:stencil-translate-axis
+ single-mmr-stil
+ ;; Ugh, hard-coded, why 1?
+ 1
+ Y)
+ single-mmr-stil)))
+ (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4)))))
+ ;; Adjust the space between the mmr-glyphs,
+ ;; if not default-glyphs are used.
+ (word-space (if (member style
+ '(neomensural mensural petrucci))
+ (/ (* word-space 2) 3)
+ word-space))
+ ;; Create the final mmr-stencil
+ ;; via `stack-stencil-line´ from /scm/markup.scm
+ (mmr-stil (stack-stencil-line word-space mmr-stils-list)))
+
+ ;; Print the number above a multi-measure-rest
+ ;; Depends on duration, style and multi-measure-rest-number set #t
+ (if (and multi-measure-rest
+ multi-measure-rest-number
+ (> mmr-duration 1)
+ (not (member style '(neomensural mensural petrucci))))
+ (let* ((mmr-stil-x-center
+ (interval-center (ly:stencil-extent mmr-stil X)))
+ (duration-markup
+ (markup
+ #:fontsize -2
+ #:override '(font-encoding . fetaText)
+ (number->string mmr-duration)))
+ (mmr-number-stil
+ (interpret-markup layout props duration-markup))
+ (mmr-number-stil-x-center
+ (interval-center (ly:stencil-extent mmr-number-stil X))))
+
+ (set! mmr-stil (ly:stencil-combine-at-edge
+ mmr-stil
+ Y UP
+ (ly:stencil-translate-axis
+ mmr-number-stil
+ (- mmr-stil-x-center mmr-number-stil-x-center)
+ X)
+ ;; Ugh, hardcoded
+ 0.8))))
+ (if multi-measure-rest
+ mmr-stil
+ stil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; translating.
}
@end lilypond"
(ly:stencil-translate-axis (interpret-markup layout props arg)
- (- amount) Y))
+ (- amount) Y))
(define-markup-command (translate-scaled layout props offset arg)
(number-pair? markup?)
;; should stack mols separately, to maintain LINE on baseline
(stack (stack-lines DOWN padding baseline (list m1 line m2))))
(set! stack
- (ly:stencil-aligned-to stack Y CENTER))
+ (ly:stencil-aligned-to stack Y CENTER))
(set! stack
- (ly:stencil-aligned-to stack X LEFT))
+ (ly:stencil-aligned-to stack X LEFT))
;; should have EX dimension
;; empirical anyway
(ly:stencil-translate-axis stack offset Y))))
(markup?)
#:category font
#:properties ((font-size 0)
- (baseline-skip))
+ (baseline-skip))
"
@cindex superscript text
}
@end lilypond"
(ly:stencil-translate (interpret-markup layout props arg)
- offset))
+ offset))
(define-markup-command (sub layout props arg)
(markup?)
#:category font
#:properties ((font-size 0)
- (baseline-skip))
+ (baseline-skip))
"
@cindex subscript text
(markup?)
#:category graphic
#:properties ((angularity 0)
- (padding)
- (size 1)
- (thickness 1)
- (width 0.25))
+ (padding)
+ (size 1)
+ (thickness 1)
+ (width 0.25))
"
@cindex placing parentheses around text
}
@end lilypond"
(let* ((markup (interpret-markup layout props arg))
- (scaled-width (* size width))
- (scaled-thickness
- (* (chain-assoc-get 'line-thickness props 0.1)
- thickness))
- (half-thickness
- (min (* size 0.5 scaled-thickness)
- (* (/ 4 3.0) scaled-width)))
- (padding (chain-assoc-get 'padding props half-thickness)))
+ (scaled-width (* size width))
+ (scaled-thickness
+ (* (chain-assoc-get 'line-thickness props 0.1)
+ thickness))
+ (half-thickness
+ (min (* size 0.5 scaled-thickness)
+ (* (/ 4 3.0) scaled-width)))
+ (padding (chain-assoc-get 'padding props half-thickness)))
(parenthesize-stencil
markup half-thickness scaled-width angularity padding)))
the maximum width of the page number, and @var{default} the value to display
when @var{label} is not found."
(let* ((gauge-stencil (interpret-markup layout props gauge))
- (x-ext (ly:stencil-extent gauge-stencil X))
- (y-ext (ly:stencil-extent gauge-stencil Y)))
+ (x-ext (ly:stencil-extent gauge-stencil X))
+ (y-ext (ly:stencil-extent gauge-stencil Y)))
(ly:make-stencil
`(delay-stencil-evaluation
,(delay (ly:stencil-expr
- (let* ((table (ly:output-def-lookup layout 'label-page-table))
- (page-number (if (list? table)
- (assoc-get label table)
- #f))
- (page-markup (if page-number (format #f "~a" page-number) default))
- (page-stencil (interpret-markup layout props page-markup))
- (gap (- (interval-length x-ext)
- (interval-length (ly:stencil-extent page-stencil X)))))
- (interpret-markup layout props
- (markup #:hspace gap page-markup))))))
+ (let* ((table (ly:output-def-lookup layout 'label-page-table))
+ (page-number (if (list? table)
+ (assoc-get label table)
+ #f))
+ (page-markup (if page-number (format #f "~a" page-number) default))
+ (page-stencil (interpret-markup layout props page-markup))
+ (gap (- (interval-length x-ext)
+ (interval-length (ly:stencil-extent page-stencil X)))))
+ (interpret-markup layout props
+ (markup #:hspace gap page-markup))))))
x-ext
y-ext)))
}
@end lilypond"
(let ((stil (interpret-markup layout props arg))
- (sx (car factor-pair))
- (sy (cdr factor-pair)))
+ (sx (car factor-pair))
+ (sy (cdr factor-pair)))
(ly:stencil-scale stil sx sy)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
}
@end lilypond"
(let ((pattern-width (interval-length
- (ly:stencil-extent (interpret-markup layout props pattern) X)))
+ (ly:stencil-extent (interpret-markup layout props pattern) X)))
(new-props (prepend-alist-chain 'word-space 0 (prepend-alist-chain 'baseline-skip 0 props))))
(let loop ((i (1- count)) (patterns (markup)))
(if (zero? i)
(interpret-markup
- layout
- new-props
- (if (= axis X)
- (markup patterns pattern)
- (markup #:column (patterns pattern))))
+ layout
+ new-props
+ (if (= axis X)
+ (markup patterns pattern)
+ (markup #:column (patterns pattern))))
(loop (1- i)
- (if (= axis X)
- (markup patterns pattern #:hspace space)
- (markup #:column (patterns pattern #:vspace space))))))))
+ (if (= axis X)
+ (markup patterns pattern #:hspace space)
+ (markup #:column (patterns pattern #:vspace space))))))))
(define-markup-command (fill-with-pattern layout props space dir pattern left right)
(number? ly:dir? markup? markup? markup?)
(define-public (space-lines baseline stils)
(let space-stil ((stils stils)
- (result (list)))
+ (result (list)))
(if (null? stils)
- (reverse! result)
- (let* ((stil (car stils))
- (dy-top (max (- (/ baseline 1.5)
- (interval-bound (ly:stencil-extent stil Y) UP))
- 0.0))
- (dy-bottom (max (+ (/ baseline 3.0)
- (interval-bound (ly:stencil-extent stil Y) DOWN))
- 0.0))
- (new-stil (ly:make-stencil
- (ly:stencil-expr stil)
- (ly:stencil-extent stil X)
- (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN)
- dy-bottom)
- (+ (interval-bound (ly:stencil-extent stil Y) UP)
- dy-top)))))
- (space-stil (cdr stils) (cons new-stil result))))))
+ (reverse! result)
+ (let* ((stil (car stils))
+ (dy-top (max (- (/ baseline 1.5)
+ (interval-bound (ly:stencil-extent stil Y) UP))
+ 0.0))
+ (dy-bottom (max (+ (/ baseline 3.0)
+ (interval-bound (ly:stencil-extent stil Y) DOWN))
+ 0.0))
+ (new-stil (ly:make-stencil
+ (ly:stencil-expr stil)
+ (ly:stencil-extent stil X)
+ (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN)
+ dy-bottom)
+ (+ (interval-bound (ly:stencil-extent stil Y) UP)
+ dy-top)))))
+ (space-stil (cdr stils) (cons new-stil result))))))
(define-markup-list-command (justified-lines layout props args)
(markup-list?)
#:properties ((baseline-skip)
- wordwrap-internal-markup-list)
+ wordwrap-internal-markup-list)
"
@cindex justifying lines of text
(define-markup-list-command (wordwrap-lines layout props args)
(markup-list?)
#:properties ((baseline-skip)
- wordwrap-internal-markup-list)
+ wordwrap-internal-markup-list)
"Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
where @var{X} is the number of staff spaces."
"Like @code{\\column}, but return a list of lines instead of a single markup.
@code{baseline-skip} determines the space between each markup in @var{args}."
(space-lines baseline-skip
- (interpret-markup-list layout props args)))
+ (interpret-markup-list layout props args)))
(define-markup-list-command (override-lines layout props new-prop args)
(pair? markup-list?)
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 1998--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
-;;;; Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Neil Puttock <n.puttock@gmail.com>
;;;; Carl Sorensen <c_sorensen@byu.edu>
;;;;
"Generate events for multimeasure rests,
to be used by the sequential-iterator"
(let ((location (ly:music-property music 'origin))
- (duration (ly:music-property music 'duration)))
+ (duration (ly:music-property music 'duration)))
(list (make-music 'BarCheck
- 'origin location)
- (make-event-chord (cons (make-music 'MultiMeasureRestEvent
- 'origin location
- 'duration duration)
- (ly:music-property music 'articulations)))
- (make-music 'BarCheck
- 'origin location))))
+ 'origin location)
+ (make-event-chord (cons (make-music 'MultiMeasureRestEvent
+ 'origin location
+ 'duration duration)
+ (ly:music-property music 'articulations)))
+ (make-music 'BarCheck
+ 'origin location))))
(define (make-volta-set music)
(let* ((alts (ly:music-property music 'elements))
(times (ly:music-property music 'repeat-count)))
(map (lambda (x y)
(make-music
- 'SequentialMusic
- 'elements
- ;; set properties for proper bar numbering
- (append
+ 'SequentialMusic
+ 'elements
+ ;; set properties for proper bar numbering
+ (append
+ (list (make-music 'AlternativeEvent
+ 'alternative-dir (if (= y 0)
+ -1
+ 0)
+ 'alternative-increment
+ (if (= 0 y)
+ (1+ (- times
+ lalts))
+ 1)))
+ (list x)
+ (if (= y (1- lalts))
(list (make-music 'AlternativeEvent
- 'alternative-dir (if (= y 0)
- -1
- 0)
- 'alternative-increment
- (if (= 0 y)
- (1+ (- times
- lalts))
- 1)))
- (list x)
- (if (= y (1- lalts))
- (list (make-music 'AlternativeEvent
- 'alternative-dir 1
- 'alternative-increment 0))
- '()))))
+ 'alternative-dir 1
+ 'alternative-increment 0))
+ '()))))
alts
(iota lalts))))
(let ((octavation (ly:music-property music 'ottava-number)))
(list (context-spec-music
- (make-apply-context
- (lambda (context)
- (let ((offset (* -7 octavation))
- (string (assoc-get octavation '((2 . "15ma")
- (1 . "8va")
- (0 . #f)
- (-1 . "8vb")
- (-2 . "15mb")))))
- (set! (ly:context-property context 'middleCOffset) offset)
- (set! (ly:context-property context 'ottavation) string)
- (ly:set-middle-C! context))))
- 'Staff))))
+ (make-apply-context
+ (lambda (context)
+ (let ((offset (* -7 octavation))
+ (string (assoc-get octavation '((2 . "15ma")
+ (1 . "8va")
+ (0 . #f)
+ (-1 . "8vb")
+ (-2 . "15mb")))))
+ (set! (ly:context-property context 'middleCOffset) offset)
+ (set! (ly:context-property context 'ottavation) string)
+ (ly:set-middle-C! context))))
+ 'Staff))))
(define (make-time-signature-set music)
"Set context properties for a time signature."
(structure (ly:music-property music 'beat-structure))
(fraction (cons num den)))
(list (descend-to-context
- (context-spec-music
- (make-apply-context
- (lambda (context)
- (let* ((time-signature-settings
- (ly:context-property context 'timeSignatureSettings))
- (my-base-length
- (base-length fraction time-signature-settings))
- (my-beat-structure
- (if (null? structure)
- (beat-structure my-base-length
- fraction
- time-signature-settings)
- structure))
- (beaming-exception
- (beam-exceptions fraction time-signature-settings))
- (new-measure-length (ly:make-moment num den)))
- (ly:context-set-property!
- context 'timeSignatureFraction fraction)
- (ly:context-set-property!
- context 'baseMoment (ly:make-moment my-base-length))
- (ly:context-set-property!
- context 'beatStructure my-beat-structure)
- (ly:context-set-property!
- context 'beamExceptions beaming-exception)
- (ly:context-set-property!
- context 'measureLength new-measure-length))))
- 'Timing)
- 'Score))))
+ (context-spec-music
+ (make-apply-context
+ (lambda (context)
+ (let* ((time-signature-settings
+ (ly:context-property context 'timeSignatureSettings))
+ (my-base-length
+ (base-length fraction time-signature-settings))
+ (my-beat-structure
+ (if (null? structure)
+ (beat-structure my-base-length
+ fraction
+ time-signature-settings)
+ structure))
+ (beaming-exception
+ (beam-exceptions fraction time-signature-settings))
+ (new-measure-length (ly:make-moment num den)))
+ (ly:context-set-property!
+ context 'timeSignatureFraction fraction)
+ (ly:context-set-property!
+ context 'baseMoment (ly:make-moment my-base-length))
+ (ly:context-set-property!
+ context 'beatStructure my-beat-structure)
+ (ly:context-set-property!
+ context 'beamExceptions beaming-exception)
+ (ly:context-set-property!
+ context 'measureLength new-measure-length))))
+ 'Timing)
+ 'Score))))
(cond ((or (number? scm-arg)
(string? scm-arg)
(boolean? scm-arg))
- (format #f "~s" scm-arg))
- ((or (symbol? scm-arg)
- (list? scm-arg))
- (format #f "'~s" scm-arg))
- ((procedure? scm-arg)
- (format #f "~a"
- (or (procedure-name scm-arg)
- (with-output-to-string
- (lambda ()
- (pretty-print (procedure-source scm-arg)))))))
- (else
- (format #f "~a"
- (with-output-to-string
- (lambda ()
- (display-scheme-music scm-arg)))))))
+ (format #f "~s" scm-arg))
+ ((or (symbol? scm-arg)
+ (list? scm-arg))
+ (format #f "'~s" scm-arg))
+ ((procedure? scm-arg)
+ (format #f "~a"
+ (or (procedure-name scm-arg)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source scm-arg)))))))
+ (else
+ (format #f "~a"
+ (with-output-to-string
+ (lambda ()
+ (display-scheme-music scm-arg)))))))
;;;
;;; Markups
;;;
(define (proc->command proc)
(let ((cmd-markup (symbol->string (procedure-name proc))))
(substring cmd-markup 0 (- (string-length cmd-markup)
- (string-length "-markup")))))
+ (string-length "-markup")))))
(define (arg->string arg)
(cond ((string? arg)
- (format #f "~s" arg))
- ((markup? arg) ;; a markup
- (markup->lily-string-aux arg))
- ((and (pair? arg) (every markup? arg)) ;; a markup list
- (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg)))
- (else ;; a scheme argument
- (format #f "#~a" (scheme-expr->lily-string arg)))))
+ (format #f "~s" arg))
+ ((markup? arg) ;; a markup
+ (markup->lily-string-aux arg))
+ ((and (pair? arg) (every markup? arg)) ;; a markup list
+ (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg)))
+ (else ;; a scheme argument
+ (format #f "#~a" (scheme-expr->lily-string arg)))))
(define (markup->lily-string-aux expr)
(if (string? expr)
- (format #f "~s" expr)
- (let ((cmd (car expr))
- (args (cdr expr)))
- (if (eqv? cmd simple-markup) ;; a simple markup
- (format #f "~s" (car args))
- (format #f "\\~a~{ ~a~}"
- (proc->command cmd)
- (map-in-order arg->string args))))))
+ (format #f "~s" expr)
+ (let ((cmd (car expr))
+ (args (cdr expr)))
+ (if (eqv? cmd simple-markup) ;; a simple markup
+ (format #f "~s" (car args))
+ (format #f "\\~a~{ ~a~}"
+ (proc->command cmd)
+ (map-in-order arg->string args))))))
(cond ((string? markup-expr)
- (format #f "~s" markup-expr))
- ((eqv? (car markup-expr) simple-markup)
- (format #f "~s" (second markup-expr)))
- (else
- (format #f "\\markup ~a"
- (markup->lily-string-aux markup-expr)))))
+ (format #f "~s" markup-expr))
+ ((eqv? (car markup-expr) simple-markup)
+ (format #f "~s" (second markup-expr)))
+ (else
+ (format #f "\\markup ~a"
+ (markup->lily-string-aux markup-expr)))))
;;;
;;; pitch names
(result #f result))
((or result (null? alist)) result)
(if (and (car alist) (test item (cdar alist)))
- (set! result (car alist)))))
+ (set! result (car alist)))))
(define-public (note-name->lily-string ly-pitch parser)
;; here we define a custom pitch= function, since we do not want to
;; test whether octaves are also equal. (otherwise, we would be using equal?)
(define (pitch= pitch1 pitch2)
(and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2))
- (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
+ (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
(let ((result (rassoc ly-pitch (ly:parser-lookup parser 'pitchnames) pitch=)))
(if result
- (car result)
- #f)))
+ (car result)
+ #f)))
(define-public (octave->lily-string pitch)
(let ((octave (ly:pitch-octave pitch)))
(cond ((>= octave 0)
- (make-string (1+ octave) #\'))
- ((< octave -1)
- (make-string (1- (* -1 octave)) #\,))
- (else ""))))
+ (make-string (1+ octave) #\'))
+ ((< octave -1)
+ (make-string (1- (* -1 octave)) #\,))
+ (else ""))))
;;;
;;; durations
;;;
(define*-public (duration->lily-string ly-duration #:key (prev-duration (*previous-duration*))
- (force-duration (*force-duration*))
- (time-scale (*time-scale*))
- remember)
+ (force-duration (*force-duration*))
+ (time-scale (*time-scale*))
+ remember)
(if remember (*previous-duration* ly-duration))
- (let ((log2 (ly:duration-log ly-duration))
- (dots (ly:duration-dot-count ly-duration))
- (scale (ly:duration-scale ly-duration)))
+ (let ((log2 (ly:duration-log ly-duration))
+ (dots (ly:duration-dot-count ly-duration))
+ (scale (ly:duration-scale ly-duration)))
(if (or force-duration (not prev-duration) (not (equal? ly-duration prev-duration)))
- (string-append (case log2
- ((-1) "\\breve")
- ((-2) "\\longa")
- ((-3) "\\maxima")
- (else (number->string (expt 2 log2))))
- (make-string dots #\.)
- (let ((end-scale (/ scale time-scale)))
- (if (= end-scale 1) ""
- (format #f "*~a" end-scale))))
- "")))
+ (string-append (case log2
+ ((-1) "\\breve")
+ ((-2) "\\longa")
+ ((-3) "\\maxima")
+ (else (number->string (expt 2 log2))))
+ (make-string dots #\.)
+ (let ((end-scale (/ scale time-scale)))
+ (if (= end-scale 1) ""
+ (format #f "*~a" end-scale))))
+ "")))
;;;
;;; post events
(define* (event-direction->lily-string event #:optional (required #t))
(let ((direction (ly:music-property event 'direction)))
(cond ((or (not direction) (null? direction) (= CENTER direction))
- (if required "-" ""))
- ((= UP direction) "^")
- ((= DOWN direction) "_")
- (else ""))))
+ (if required "-" ""))
+ ((= UP direction) "^")
+ ((= DOWN direction) "_")
+ (else ""))))
(define-macro (define-post-event-display-method type vars direction-required str)
`(define-display-method ,type ,vars
(format #f "~a~a"
- (event-direction->lily-string ,(car vars) ,direction-required)
- ,str)))
+ (event-direction->lily-string ,(car vars) ,direction-required)
+ ,str)))
(define-macro (define-span-event-display-method type vars direction-required str-start str-stop)
`(define-display-method ,type ,vars
(format #f "~a~a"
- (event-direction->lily-string ,(car vars) ,direction-required)
- (if (= START (ly:music-property ,(car vars) 'span-direction))
- ,str-start
- ,str-stop))))
+ (event-direction->lily-string ,(car vars) ,direction-required)
+ (if (= START (ly:music-property ,(car vars) 'span-direction))
+ ,str-start
+ ,str-stop))))
(define-display-method HyphenEvent (event parser)
" --")
(define-display-method TremoloEvent (event parser)
(let ((tremolo-type (ly:music-property event 'tremolo-type)))
(format #f ":~a" (if (= 0 tremolo-type)
- ""
- tremolo-type))))
+ ""
+ tremolo-type))))
(define-display-method ArticulationEvent (event parser) #t
(let* ((articulation (ly:music-property event 'articulation-type))
- (shorthand
- (case (string->symbol articulation)
- ((marcato) "^")
- ((stopped) "+")
- ((tenuto) "-")
- ((staccatissimo) "|")
- ((accent) ">")
- ((staccato) ".")
- ((portato) "_")
- (else #f))))
+ (shorthand
+ (case (string->symbol articulation)
+ ((marcato) "^")
+ ((stopped) "+")
+ ((tenuto) "-")
+ ((staccatissimo) "|")
+ ((accent) ">")
+ ((staccato) ".")
+ ((portato) "_")
+ (else #f))))
(format #f "~a~:[\\~;~]~a"
- (event-direction->lily-string event shorthand)
- shorthand
- (or shorthand articulation))))
+ (event-direction->lily-string event shorthand)
+ shorthand
+ (or shorthand articulation))))
(define-post-event-display-method FingeringEvent (event parser) #t
(ly:music-property event 'digit))
(define-display-method GraceMusic (expr parser)
(format #f "\\grace ~a"
- (music->lily-string (ly:music-property expr 'element) parser)))
+ (music->lily-string (ly:music-property expr 'element) parser)))
;; \acciaccatura \appoggiatura \grace
;; TODO: it would be better to compare ?start and ?stop
(define-extra-display-method GraceMusic (expr parser)
"Display method for appoggiatura."
(with-music-match (expr (music
- 'GraceMusic
- element (music
- 'SequentialMusic
- elements (?start
- ?music
- ?stop))))
- ;; we check whether ?start and ?stop look like
- ;; startAppoggiaturaMusic stopAppoggiaturaMusic
- (and (with-music-match (?start (music
- 'SequentialMusic
- elements ((music
- 'EventChord
- elements
- ((music
- 'SlurEvent
- span-direction START))))))
- #t)
- (with-music-match (?stop (music
- 'SequentialMusic
- elements ((music
- 'EventChord
- elements
- ((music
- 'SlurEvent
- span-direction STOP))))))
- (format #f "\\appoggiatura ~a" (music->lily-string ?music parser))))))
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startAppoggiaturaMusic stopAppoggiaturaMusic
+ (and (with-music-match (?start (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements
+ ((music
+ 'SlurEvent
+ span-direction START))))))
+ #t)
+ (with-music-match (?stop (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements
+ ((music
+ 'SlurEvent
+ span-direction STOP))))))
+ (format #f "\\appoggiatura ~a" (music->lily-string ?music parser))))))
(define-extra-display-method GraceMusic (expr parser)
"Display method for acciaccatura."
(with-music-match (expr (music
- 'GraceMusic
- element (music
- 'SequentialMusic
- elements (?start
- ?music
- ?stop))))
- ;; we check whether ?start and ?stop look like
- ;; startAcciaccaturaMusic stopAcciaccaturaMusic
- (and (with-music-match (?start (music
- 'SequentialMusic
- elements ((music
- 'EventChord
- elements
- ((music
- 'SlurEvent
- span-direction START)))
- (music
- 'ContextSpeccedMusic
- element (music
- 'OverrideProperty
- grob-property-path '(stroke-style)
- grob-value "grace"
- symbol 'Flag)))))
- #t)
- (with-music-match (?stop (music
- 'SequentialMusic
- elements ((music
- 'ContextSpeccedMusic
- element (music
- 'RevertProperty
- grob-property-path '(stroke-style)
- symbol 'Flag))
-
- (music
- 'EventChord
- elements
- ((music
- 'SlurEvent
- span-direction STOP))))))
- (format #f "\\acciaccatura ~a" (music->lily-string ?music parser))))))
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startAcciaccaturaMusic stopAcciaccaturaMusic
+ (and (with-music-match (?start (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements
+ ((music
+ 'SlurEvent
+ span-direction START)))
+ (music
+ 'ContextSpeccedMusic
+ element (music
+ 'OverrideProperty
+ grob-property-path '(stroke-style)
+ grob-value "grace"
+ symbol 'Flag)))))
+ #t)
+ (with-music-match (?stop (music
+ 'SequentialMusic
+ elements ((music
+ 'ContextSpeccedMusic
+ element (music
+ 'RevertProperty
+ grob-property-path '(stroke-style)
+ symbol 'Flag))
+
+ (music
+ 'EventChord
+ elements
+ ((music
+ 'SlurEvent
+ span-direction STOP))))))
+ (format #f "\\acciaccatura ~a" (music->lily-string ?music parser))))))
(define-extra-display-method GraceMusic (expr parser)
"Display method for grace."
(with-music-match (expr (music
- 'GraceMusic
- element (music
- 'SequentialMusic
- elements (?start
- ?music
- ?stop))))
- ;; we check whether ?start and ?stop look like
- ;; startGraceMusic stopGraceMusic
- (and (null? (ly:music-property ?start 'elements))
- (null? (ly:music-property ?stop 'elements))
- (format #f "\\grace ~a" (music->lily-string ?music parser)))))
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startGraceMusic stopGraceMusic
+ (and (null? (ly:music-property ?start 'elements))
+ (null? (ly:music-property ?stop 'elements))
+ (format #f "\\grace ~a" (music->lily-string ?music parser)))))
;;;
;;; Music sequences
(define-display-method SequentialMusic (seq parser)
(let ((force-line-break (and (*force-line-break*)
- ;; hm
- (> (length (ly:music-property seq 'elements))
- (*max-element-number-before-break*))))
- (elements (ly:music-property seq 'elements))
- (chord? (make-music-type-predicate 'EventChord))
- (note-or-chord? (make-music-type-predicate 'EventChord 'NoteEvent
- 'LyricEvent 'RestEvent
- 'ClusterNoteEvent))
- (cluster? (make-music-type-predicate 'ClusterNoteEvent))
- (note? (make-music-type-predicate 'NoteEvent)))
+ ;; hm
+ (> (length (ly:music-property seq 'elements))
+ (*max-element-number-before-break*))))
+ (elements (ly:music-property seq 'elements))
+ (chord? (make-music-type-predicate 'EventChord))
+ (note-or-chord? (make-music-type-predicate 'EventChord 'NoteEvent
+ 'LyricEvent 'RestEvent
+ 'ClusterNoteEvent))
+ (cluster? (make-music-type-predicate 'ClusterNoteEvent))
+ (note? (make-music-type-predicate 'NoteEvent)))
(format #f "~a~a{~v%~v_~{~a~^ ~}~v%~v_}"
- (if (any (lambda (e)
- (or (cluster? e)
- (and (chord? e)
- (any cluster? (ly:music-property e 'elements)))))
- elements)
- "\\makeClusters "
- "")
- (if (*explicit-mode*)
- ;; if the sequence contains EventChord which contains figures ==> figuremode
- ;; if the sequence contains EventChord which contains lyrics ==> lyricmode
- ;; if the sequence contains EventChord which contains drum notes ==> drummode
- (cond ((any (lambda (chord)
- (any (make-music-type-predicate 'BassFigureEvent)
- (ly:music-property chord 'elements)))
- (filter chord? elements))
- "\\figuremode ")
- ((any (lambda (chord)
- (any (make-music-type-predicate 'LyricEvent)
- (cons chord
- (ly:music-property chord 'elements))))
- (filter note-or-chord? elements))
- "\\lyricmode ")
- ((any (lambda (chord)
- (any (lambda (event)
- (and (note? event)
- (not (null? (ly:music-property event 'drum-type)))))
- (cons chord
- (ly:music-property chord 'elements))))
- (filter note-or-chord? elements))
- "\\drummode ")
- (else ;; TODO: other modes?
- ""))
- "")
- (if force-line-break 1 0)
- (if force-line-break (+ 2 (*indent*)) 1)
- (parameterize ((*indent* (+ 2 (*indent*))))
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- elements))
- (if force-line-break 1 0)
- (if force-line-break (*indent*) 1))))
+ (if (any (lambda (e)
+ (or (cluster? e)
+ (and (chord? e)
+ (any cluster? (ly:music-property e 'elements)))))
+ elements)
+ "\\makeClusters "
+ "")
+ (if (*explicit-mode*)
+ ;; if the sequence contains EventChord which contains figures ==> figuremode
+ ;; if the sequence contains EventChord which contains lyrics ==> lyricmode
+ ;; if the sequence contains EventChord which contains drum notes ==> drummode
+ (cond ((any (lambda (chord)
+ (any (make-music-type-predicate 'BassFigureEvent)
+ (ly:music-property chord 'elements)))
+ (filter chord? elements))
+ "\\figuremode ")
+ ((any (lambda (chord)
+ (any (make-music-type-predicate 'LyricEvent)
+ (cons chord
+ (ly:music-property chord 'elements))))
+ (filter note-or-chord? elements))
+ "\\lyricmode ")
+ ((any (lambda (chord)
+ (any (lambda (event)
+ (and (note? event)
+ (not (null? (ly:music-property event 'drum-type)))))
+ (cons chord
+ (ly:music-property chord 'elements))))
+ (filter note-or-chord? elements))
+ "\\drummode ")
+ (else ;; TODO: other modes?
+ ""))
+ "")
+ (if force-line-break 1 0)
+ (if force-line-break (+ 2 (*indent*)) 1)
+ (parameterize ((*indent* (+ 2 (*indent*))))
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ elements))
+ (if force-line-break 1 0)
+ (if force-line-break (*indent*) 1))))
(define-display-method SimultaneousMusic (sim parser)
(parameterize ((*indent* (+ 3 (*indent*))))
- (format #f "<< ~{~a ~}>>"
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- (ly:music-property sim 'elements)))))
+ (format #f "<< ~{~a ~}>>"
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ (ly:music-property sim 'elements)))))
(define-extra-display-method SimultaneousMusic (expr parser)
"If `sim' is an \afterGrace expression, return \"\\afterGrace ...\".
Otherwise, return #f."
;; TODO: do something with afterGraceFraction?
(with-music-match (expr (music 'SimultaneousMusic
- elements (?before-grace
- (music 'SequentialMusic
- elements ((music 'SkipMusic)
- (music 'GraceMusic
- element ?grace))))))
- (format #f "\\afterGrace ~a ~a"
- (music->lily-string ?before-grace parser)
- (music->lily-string ?grace parser))))
+ elements (?before-grace
+ (music 'SequentialMusic
+ elements ((music 'SkipMusic)
+ (music 'GraceMusic
+ element ?grace))))))
+ (format #f "\\afterGrace ~a ~a"
+ (music->lily-string ?before-grace parser)
+ (music->lily-string ?grace parser))))
;;;
;;; Chords
(define-display-method EventChord (chord parser)
;; event_chord : command_element
- ;; | note_chord_element
+ ;; | note_chord_element
;; TODO : tagged post_events
;; post_events : ( post_event | tagged_post_event )*
;; tagged_post_event: '-' \tag embedded_scm post_event
(let* ((elements (append (ly:music-property chord 'elements)
- (ly:music-property chord 'articulations)))
- (chord-repeat (ly:music-property chord 'duration)))
+ (ly:music-property chord 'articulations)))
+ (chord-repeat (ly:music-property chord 'duration)))
(call-with-values
- (lambda ()
- (partition (lambda (m) (music-is-of-type? m 'rhythmic-event))
- elements))
+ (lambda ()
+ (partition (lambda (m) (music-is-of-type? m 'rhythmic-event))
+ elements))
(lambda (chord-elements other-elements)
- (cond ((pair? chord-elements)
- ;; note_chord_element :
- ;; '<' (notepitch | drumpitch)* '>" duration post_events
- (let ((duration (duration->lily-string (ly:music-property
- (car chord-elements)
- 'duration)
- #:remember #t)))
- ;; Format duration first so that it does not appear on
- ;; chord elements
- (format #f "< ~{~a ~}>~a~:{~:[-~;~]~a~^ ~}"
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- chord-elements)
- duration
- (map-in-order (lambda (music)
- (list
- (post-event? music)
- (music->lily-string music parser)))
- other-elements))))
- ((ly:duration? chord-repeat)
- (let ((duration (duration->lily-string chord-repeat
- #:remember #t)))
- (format #f "q~a~:{~:[-~;~]~a~^ ~}"
- duration
- (map-in-order (lambda (music)
- (list
- (post-event? music)
- (music->lily-string music parser)))
- other-elements))))
-
- ((and (= 1 (length other-elements))
- (not (post-event? (car other-elements))))
- (format #f (music->lily-string (car other-elements) parser)))
- (else
- (format #f "< >~:{~:[-~;~]~a~^ ~}"
- (map-in-order (lambda (music)
- (list
- (post-event? music)
- (music->lily-string music parser)))
- other-elements))))))))
+ (cond ((pair? chord-elements)
+ ;; note_chord_element :
+ ;; '<' (notepitch | drumpitch)* '>" duration post_events
+ (let ((duration (duration->lily-string (ly:music-property
+ (car chord-elements)
+ 'duration)
+ #:remember #t)))
+ ;; Format duration first so that it does not appear on
+ ;; chord elements
+ (format #f "< ~{~a ~}>~a~:{~:[-~;~]~a~^ ~}"
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ chord-elements)
+ duration
+ (map-in-order (lambda (music)
+ (list
+ (post-event? music)
+ (music->lily-string music parser)))
+ other-elements))))
+ ((ly:duration? chord-repeat)
+ (let ((duration (duration->lily-string chord-repeat
+ #:remember #t)))
+ (format #f "q~a~:{~:[-~;~]~a~^ ~}"
+ duration
+ (map-in-order (lambda (music)
+ (list
+ (post-event? music)
+ (music->lily-string music parser)))
+ other-elements))))
+
+ ((and (= 1 (length other-elements))
+ (not (post-event? (car other-elements))))
+ (format #f (music->lily-string (car other-elements) parser)))
+ (else
+ (format #f "< >~:{~:[-~;~]~a~^ ~}"
+ (map-in-order (lambda (music)
+ (list
+ (post-event? music)
+ (music->lily-string music parser)))
+ other-elements))))))))
(define-display-method MultiMeasureRestMusic (mmrest parser)
(format #f "R~a~{~a~^ ~}"
- (duration->lily-string (ly:music-property mmrest 'duration)
- #:remember #t)
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- (ly:music-property mmrest 'articulations))))
+ (duration->lily-string (ly:music-property mmrest 'duration)
+ #:remember #t)
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ (ly:music-property mmrest 'articulations))))
(define-display-method SkipMusic (skip parser)
(format #f "\\skip ~a" (duration->lily-string (ly:music-property skip 'duration) #:force-duration #t)))
(define (simple-note->lily-string event parser)
(format #f "~a~a~a~a~a~a~:{~:[-~;~]~a~}" ; pitchname octave !? octave-check duration optional_rest articulations
- (note-name->lily-string (ly:music-property event 'pitch) parser)
- (octave->lily-string (ly:music-property event 'pitch))
- (let ((forced (ly:music-property event 'force-accidental))
- (cautionary (ly:music-property event 'cautionary)))
- (cond ((and (not (null? forced))
- forced
- (not (null? cautionary))
- cautionary)
- "?")
- ((and (not (null? forced)) forced) "!")
- (else "")))
- (let ((octave-check (ly:music-property event 'absolute-octave)))
- (if (not (null? octave-check))
- (format #f "=~a" (cond ((>= octave-check 0)
- (make-string (1+ octave-check) #\'))
- ((< octave-check -1)
- (make-string (1- (* -1 octave-check)) #\,))
- (else "")))
- ""))
- (duration->lily-string (ly:music-property event 'duration)
- #:remember #t)
- (if ((make-music-type-predicate 'RestEvent) event)
- "\\rest" "")
- (map-in-order (lambda (event)
- (list
- (post-event? event)
- (music->lily-string event parser)))
- (ly:music-property event 'articulations))))
+ (note-name->lily-string (ly:music-property event 'pitch) parser)
+ (octave->lily-string (ly:music-property event 'pitch))
+ (let ((forced (ly:music-property event 'force-accidental))
+ (cautionary (ly:music-property event 'cautionary)))
+ (cond ((and (not (null? forced))
+ forced
+ (not (null? cautionary))
+ cautionary)
+ "?")
+ ((and (not (null? forced)) forced) "!")
+ (else "")))
+ (let ((octave-check (ly:music-property event 'absolute-octave)))
+ (if (not (null? octave-check))
+ (format #f "=~a" (cond ((>= octave-check 0)
+ (make-string (1+ octave-check) #\'))
+ ((< octave-check -1)
+ (make-string (1- (* -1 octave-check)) #\,))
+ (else "")))
+ ""))
+ (duration->lily-string (ly:music-property event 'duration)
+ #:remember #t)
+ (if ((make-music-type-predicate 'RestEvent) event)
+ "\\rest" "")
+ (map-in-order (lambda (event)
+ (list
+ (post-event? event)
+ (music->lily-string event parser)))
+ (ly:music-property event 'articulations))))
(define-display-method NoteEvent (note parser)
(cond ((not (null? (ly:music-property note 'pitch))) ;; note
- (simple-note->lily-string note parser))
- ((not (null? (ly:music-property note 'drum-type))) ;; drum
- (format #f "~a~a~{~a~}" (ly:music-property note 'drum-type)
- (duration->lily-string (ly:music-property note 'duration)
- #:remember #t)
- (map-in-order (lambda (event)
- (music->lily-string event parser))
- (ly:music-property note 'articulations))))
- (else ;; unknown?
- "")))
+ (simple-note->lily-string note parser))
+ ((not (null? (ly:music-property note 'drum-type))) ;; drum
+ (format #f "~a~a~{~a~}" (ly:music-property note 'drum-type)
+ (duration->lily-string (ly:music-property note 'duration)
+ #:remember #t)
+ (map-in-order (lambda (event)
+ (music->lily-string event parser))
+ (ly:music-property note 'articulations))))
+ (else ;; unknown?
+ "")))
(define-display-method ClusterNoteEvent (note parser)
(simple-note->lily-string note parser))
(if (not (null? (ly:music-property rest 'pitch)))
(simple-note->lily-string rest parser)
(format #f "r~a~{~a~}"
- (duration->lily-string (ly:music-property rest 'duration)
- #:remember #t)
- (map-in-order (lambda (event)
- (music->lily-string event parser))
- (ly:music-property rest 'articulations)))))
+ (duration->lily-string (ly:music-property rest 'duration)
+ #:remember #t)
+ (map-in-order (lambda (event)
+ (music->lily-string event parser))
+ (ly:music-property rest 'articulations)))))
(define-display-method MultiMeasureRestEvent (rest parser)
(string-append "R" (duration->lily-string (ly:music-property rest 'duration)
- #:remember #t)))
+ #:remember #t)))
(define-display-method SkipEvent (rest parser)
(format #f "s~a~{~a~}"
- (duration->lily-string (ly:music-property rest 'duration)
- #:remember #t)
- (map-in-order (lambda (event)
- (music->lily-string event parser))
- (ly:music-property rest 'articulations))))
+ (duration->lily-string (ly:music-property rest 'duration)
+ #:remember #t)
+ (map-in-order (lambda (event)
+ (music->lily-string event parser))
+ (ly:music-property rest 'articulations))))
(define-display-method RepeatedChord (chord parser)
(music->lily-string (ly:music-property chord 'element) parser))
(define-display-method MarkEvent (mark parser)
(let ((label (ly:music-property mark 'label)))
(if (null? label)
- "\\mark \\default"
- (format #f "\\mark ~a" (markup->lily-string label)))))
+ "\\mark \\default"
+ (format #f "\\mark ~a" (markup->lily-string label)))))
(define-display-method KeyChangeEvent (key parser)
(let ((pitch-alist (ly:music-property key 'pitch-alist))
- (tonic (ly:music-property key 'tonic)))
+ (tonic (ly:music-property key 'tonic)))
(if (or (null? pitch-alist)
- (null? tonic))
- "\\key \\default"
- (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist
- (ly:pitch-diff (ly:make-pitch 0 0 0) tonic))))
- (format #f "\\key ~a \\~a~a"
- (note-name->lily-string (ly:music-property key 'tonic) parser)
- (any (lambda (mode)
- (if (and parser
- (equal? (ly:parser-lookup parser mode) c-pitch-alist))
- (symbol->string mode)
- #f))
- '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
- (new-line->lily-string))))))
+ (null? tonic))
+ "\\key \\default"
+ (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist
+ (ly:pitch-diff (ly:make-pitch 0 0 0) tonic))))
+ (format #f "\\key ~a \\~a~a"
+ (note-name->lily-string (ly:music-property key 'tonic) parser)
+ (any (lambda (mode)
+ (if (and parser
+ (equal? (ly:parser-lookup parser mode) c-pitch-alist))
+ (symbol->string mode)
+ #f))
+ '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
+ (new-line->lily-string))))))
(define-display-method RelativeOctaveCheck (octave parser)
(let ((pitch (ly:music-property octave 'pitch)))
(format #f "\\octaveCheck ~a~a"
- (note-name->lily-string pitch parser)
- (octave->lily-string pitch))))
+ (note-name->lily-string pitch parser)
+ (octave->lily-string pitch))))
(define-display-method VoiceSeparator (sep parser)
"\\\\")
(define-display-method BassFigureEvent (figure parser)
(let ((alteration (ly:music-property figure 'alteration))
- (fig (ly:music-property figure 'figure))
- (bracket-start (ly:music-property figure 'bracket-start))
- (bracket-stop (ly:music-property figure 'bracket-stop)))
+ (fig (ly:music-property figure 'figure))
+ (bracket-start (ly:music-property figure 'bracket-start))
+ (bracket-stop (ly:music-property figure 'bracket-stop)))
(format #f "~a~a~a~a"
- (if (null? bracket-start) "" "[")
- (cond ((null? fig) "_")
- ((markup? fig) (second fig)) ;; fig: (<number-markup> "number")
- (else fig))
- (if (null? alteration)
- ""
- (cond
- ((= alteration DOUBLE-FLAT) "--")
- ((= alteration FLAT) "-")
- ((= alteration NATURAL) "!")
- ((= alteration SHARP) "+")
- ((= alteration DOUBLE-SHARP) "++")
- (else "")))
- (if (null? bracket-stop) "" "]"))))
+ (if (null? bracket-start) "" "[")
+ (cond ((null? fig) "_")
+ ((markup? fig) (second fig)) ;; fig: (<number-markup> "number")
+ (else fig))
+ (if (null? alteration)
+ ""
+ (cond
+ ((= alteration DOUBLE-FLAT) "--")
+ ((= alteration FLAT) "-")
+ ((= alteration NATURAL) "!")
+ ((= alteration SHARP) "+")
+ ((= alteration DOUBLE-SHARP) "++")
+ (else "")))
+ (if (null? bracket-stop) "" "]"))))
(define-display-method LyricEvent (lyric parser)
(format "~a~{~a~^ ~}"
- (let ((text (ly:music-property lyric 'text)))
- (if (or (string? text)
- (eqv? (first text) simple-markup))
- ;; a string or a simple markup
- (let ((string (if (string? text)
- text
- (second text))))
- (if (string-match "(\"| |[0-9])" string)
- ;; TODO check exactly in which cases double quotes should be used
- (format #f "~s" string)
- string))
- (markup->lily-string text)))
- (map-in-order (lambda (m) (music->lily-string m parser))
- (ly:music-property lyric 'articulations))))
+ (let ((text (ly:music-property lyric 'text)))
+ (if (or (string? text)
+ (eqv? (first text) simple-markup))
+ ;; a string or a simple markup
+ (let ((string (if (string? text)
+ text
+ (second text))))
+ (if (string-match "(\"| |[0-9])" string)
+ ;; TODO check exactly in which cases double quotes should be used
+ (format #f "~s" string)
+ string))
+ (markup->lily-string text)))
+ (map-in-order (lambda (m) (music->lily-string m parser))
+ (ly:music-property lyric 'articulations))))
(define-display-method BreathingEvent (event parser)
"\\breathe")
(define-display-method AutoChangeMusic (m parser)
(format #f "\\autochange ~a"
- (music->lily-string (ly:music-property m 'element) parser)))
+ (music->lily-string (ly:music-property m 'element) parser)))
(define-display-method ContextChange (m parser)
(format #f "\\change ~a = \"~a\""
- (ly:music-property m 'change-to-type)
- (ly:music-property m 'change-to-id)))
+ (ly:music-property m 'change-to-type)
+ (ly:music-property m 'change-to-id)))
;;;
(define-display-method TimeScaledMusic (times parser)
(let* ((num (ly:music-property times 'numerator))
- (den (ly:music-property times 'denominator))
+ (den (ly:music-property times 'denominator))
(span (ly:music-property times 'duration #f))
;; need to format before changing time scale
(formatted-span
(and span (duration->lily-string span #:force-duration #t)))
- (scale (/ num den))
- (time-scale (*time-scale*)))
+ (scale (/ num den))
+ (time-scale (*time-scale*)))
(*previous-duration* #f)
(let ((result
(parameterize ((*force-line-break* #f)
(*time-scale* (* time-scale scale)))
- (format #f "\\tuplet ~a/~a ~@[~a ~]~a"
- den
- num
- formatted-span
- (music->lily-string (ly:music-property times 'element) parser)))))
+ (format #f "\\tuplet ~a/~a ~@[~a ~]~a"
+ den
+ num
+ formatted-span
+ (music->lily-string (ly:music-property times 'element) parser)))))
(*previous-duration* #f)
result)))
(define (repeat->lily-string expr repeat-type parser)
(let* ((main (music->lily-string (ly:music-property expr 'element) parser)))
(format #f "\\repeat ~a ~a ~a ~a"
- repeat-type
- (ly:music-property expr 'repeat-count)
- main
- (let ((alternatives (ly:music-property expr 'elements)))
- (if (null? alternatives)
- ""
- (format #f "\\alternative { ~{~a ~}}"
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- alternatives)))))))
+ repeat-type
+ (ly:music-property expr 'repeat-count)
+ main
+ (let ((alternatives (ly:music-property expr 'elements)))
+ (if (null? alternatives)
+ ""
+ (format #f "\\alternative { ~{~a ~}}"
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ alternatives)))))))
(define-display-method VoltaRepeatedMusic (expr parser)
(repeat->lily-string expr "volta" parser))
(define-display-method TremoloRepeatedMusic (expr parser)
(let* ((main (ly:music-property expr 'element))
- (children (if (music-is-of-type? main 'sequential-music)
- ;; \repeat tremolo n { ... }
- (length (extract-named-music main '(EventChord
- NoteEvent)))
- ;; \repeat tremolo n c4
- 1))
- (times (ly:music-property expr 'repeat-count))
-
- ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
- (dots (1- (logcount (* times children))))
- ;; The remaining missing multiplicator to scale the notes by
- ;; times * children
- (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
- (shift (- (ly:intlog2 (floor mult)))))
+ (children (if (music-is-of-type? main 'sequential-music)
+ ;; \repeat tremolo n { ... }
+ (length (extract-named-music main '(EventChord
+ NoteEvent)))
+ ;; \repeat tremolo n c4
+ 1))
+ (times (ly:music-property expr 'repeat-count))
+
+ ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
+ (dots (1- (logcount (* times children))))
+ ;; The remaining missing multiplicator to scale the notes by
+ ;; times * children
+ (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
+ (shift (- (ly:intlog2 (floor mult)))))
(set! main (ly:music-deep-copy main))
;; Adjust the time of the notes
(ly:music-compress main (ly:make-moment children 1))
;; Adjust the displayed note durations
(shift-duration-log main (- shift) (- dots))
(format #f "\\repeat tremolo ~a ~a"
- times
- (music->lily-string main parser))))
+ times
+ (music->lily-string main parser))))
;;;
;;; Contexts
(define-display-method ContextSpeccedMusic (expr parser)
(let ((id (ly:music-property expr 'context-id))
- (create-new (ly:music-property expr 'create-new))
- (music (ly:music-property expr 'element))
- (operations (ly:music-property expr 'property-operations))
- (ctype (ly:music-property expr 'context-type)))
+ (create-new (ly:music-property expr 'create-new))
+ (music (ly:music-property expr 'element))
+ (operations (ly:music-property expr 'property-operations))
+ (ctype (ly:music-property expr 'context-type)))
(format #f "~a ~a~a~a ~a"
- (if (and (not (null? create-new)) create-new)
- "\\new"
- "\\context")
- ctype
- (if (null? id)
- ""
- (format #f " = ~s" id))
- (if (null? operations)
- ""
- (format #f " \\with {~{~a~}~%~v_}"
- (parameterize ((*indent* (+ (*indent*) 2)))
- (map (lambda (op)
- (format #f "~%~v_\\~a ~s"
- (*indent*)
- (first op)
- (second op)))
- operations))
- (*indent*)))
- (parameterize ((*current-context* ctype))
- (music->lily-string music parser)))))
+ (if (and (not (null? create-new)) create-new)
+ "\\new"
+ "\\context")
+ ctype
+ (if (null? id)
+ ""
+ (format #f " = ~s" id))
+ (if (null? operations)
+ ""
+ (format #f " \\with {~{~a~}~%~v_}"
+ (parameterize ((*indent* (+ (*indent*) 2)))
+ (map (lambda (op)
+ (format #f "~%~v_\\~a ~s"
+ (*indent*)
+ (first op)
+ (second op)))
+ operations))
+ (*indent*)))
+ (parameterize ((*current-context* ctype))
+ (music->lily-string music parser)))))
;; special cases: \figures \lyrics \drums
(define-extra-display-method ContextSpeccedMusic (expr parser)
(with-music-match (expr (music 'ContextSpeccedMusic
- create-new #t
- property-operations ?op
- context-type ?context-type
- element ?sequence))
- (if (null? ?op)
- (parameterize ((*explicit-mode* #f))
- (case ?context-type
- ((FiguredBass)
- (format #f "\\figures ~a" (music->lily-string ?sequence parser)))
- ((Lyrics)
- (format #f "\\lyrics ~a" (music->lily-string ?sequence parser)))
- ((DrumStaff)
- (format #f "\\drums ~a" (music->lily-string ?sequence parser)))
- (else
- #f)))
- #f)))
+ create-new #t
+ property-operations ?op
+ context-type ?context-type
+ element ?sequence))
+ (if (null? ?op)
+ (parameterize ((*explicit-mode* #f))
+ (case ?context-type
+ ((FiguredBass)
+ (format #f "\\figures ~a" (music->lily-string ?sequence parser)))
+ ((Lyrics)
+ (format #f "\\lyrics ~a" (music->lily-string ?sequence parser)))
+ ((DrumStaff)
+ (format #f "\\drums ~a" (music->lily-string ?sequence parser)))
+ (else
+ #f)))
+ #f)))
;;; Context properties
(define-extra-display-method ContextSpeccedMusic (expr parser)
(let ((element (ly:music-property expr 'element))
- (property-tuning? (make-music-type-predicate 'PropertySet
- 'PropertyUnset
- 'OverrideProperty
- 'RevertProperty))
- (sequence? (make-music-type-predicate 'SequentialMusic)))
+ (property-tuning? (make-music-type-predicate 'PropertySet
+ 'PropertyUnset
+ 'OverrideProperty
+ 'RevertProperty))
+ (sequence? (make-music-type-predicate 'SequentialMusic)))
(if (and (ly:music? element)
- (or (property-tuning? element)
- (and (sequence? element)
- (every property-tuning? (ly:music-property element 'elements)))))
- (parameterize ((*current-context* (ly:music-property expr 'context-type)))
- (music->lily-string element parser))
- #f)))
+ (or (property-tuning? element)
+ (and (sequence? element)
+ (every property-tuning? (ly:music-property element 'elements)))))
+ (parameterize ((*current-context* (ly:music-property expr 'context-type)))
+ (music->lily-string element parser))
+ #f)))
(define (property-value->lily-string arg parser)
(cond ((ly:music? arg)
- (music->lily-string arg parser))
- ((string? arg)
- (format #f "#~s" arg))
- ((markup? arg)
- (markup->lily-string arg))
- (else
- (format #f "#~a" (scheme-expr->lily-string arg)))))
+ (music->lily-string arg parser))
+ ((string? arg)
+ (format #f "#~s" arg))
+ ((markup? arg)
+ (markup->lily-string arg))
+ (else
+ (format #f "#~a" (scheme-expr->lily-string arg)))))
(define-display-method PropertySet (expr parser)
(let ((property (ly:music-property expr 'symbol))
- (value (ly:music-property expr 'value))
- (once (ly:music-property expr 'once)))
+ (value (ly:music-property expr 'value))
+ (once (ly:music-property expr 'once)))
(format #f "~a\\set ~a~a = ~a~a"
- (if (and (not (null? once)))
- "\\once "
- "")
- (if (eqv? (*current-context*) 'Bottom)
- ""
- (format #f "~a . " (*current-context*)))
- property
- (property-value->lily-string value parser)
- (new-line->lily-string))))
+ (if (and (not (null? once)))
+ "\\once "
+ "")
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ property
+ (property-value->lily-string value parser)
+ (new-line->lily-string))))
(define-display-method PropertyUnset (expr parser)
(format #f "\\unset ~a~a~a"
- (if (eqv? (*current-context*) 'Bottom)
- ""
- (format #f "~a . " (*current-context*)))
- (ly:music-property expr 'symbol)
- (new-line->lily-string)))
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ (ly:music-property expr 'symbol)
+ (new-line->lily-string)))
;;; Layout properties
(define-display-method OverrideProperty (expr parser)
- (let* ((symbol (ly:music-property expr 'symbol))
- (properties (ly:music-property expr 'grob-property-path
- (list (ly:music-property expr 'grob-property))))
- (value (ly:music-property expr 'grob-value))
- (once (ly:music-property expr 'once)))
+ (let* ((symbol (ly:music-property expr 'symbol))
+ (properties (ly:music-property expr 'grob-property-path
+ (list (ly:music-property expr 'grob-property))))
+ (value (ly:music-property expr 'grob-value))
+ (once (ly:music-property expr 'once)))
(format #f "~a\\override ~{~a~^.~} = ~a~a"
- (if (or (null? once)
- (not once))
- ""
- "\\once ")
+ (if (or (null? once)
+ (not once))
+ ""
+ "\\once ")
(if (eqv? (*current-context*) 'Bottom)
(cons symbol properties)
(cons* (*current-context*) symbol properties))
(property-value->lily-string value parser)
- (new-line->lily-string))))
+ (new-line->lily-string))))
(define-display-method RevertProperty (expr parser)
(let* ((symbol (ly:music-property expr 'symbol))
(properties (ly:music-property expr 'grob-property-path
- (list (ly:music-property expr 'grob-property)))))
+ (list (ly:music-property expr 'grob-property)))))
(format #f "\\revert ~{~a~^.~}~a"
(if (eqv? (*current-context*) 'Bottom)
(cons symbol properties)
(cons* (*current-context*) symbol properties))
- (new-line->lily-string))))
+ (new-line->lily-string))))
(define-display-method TimeSignatureMusic (expr parser)
(let* ((num (ly:music-property expr 'numerator))
num den
(new-line->lily-string))
(format #f
- "\\time #'~a ~a/~a~a"
+ "\\time #'~a ~a/~a~a"
structure num den
(new-line->lily-string)))))
(define-extra-display-method ContextSpeccedMusic (expr parser)
"If expr is a melisma, return \"\\melisma\", otherwise, return #f."
(with-music-match (expr (music 'ContextSpeccedMusic
- element (music 'PropertySet
- value #t
- symbol 'melismaBusy)))
- "\\melisma"))
+ element (music 'PropertySet
+ value #t
+ symbol 'melismaBusy)))
+ "\\melisma"))
(define-extra-display-method ContextSpeccedMusic (expr parser)
"If expr is a melisma end, return \"\\melismaEnd\", otherwise, return #f."
(with-music-match (expr (music 'ContextSpeccedMusic
- element (music 'PropertyUnset
- symbol 'melismaBusy)))
- "\\melismaEnd"))
+ element (music 'PropertyUnset
+ symbol 'melismaBusy)))
+ "\\melismaEnd"))
;;; \tempo
(define-extra-display-method SequentialMusic (expr parser)
(with-music-match (expr (music 'SequentialMusic
- elements ((music 'TempoChangeEvent
- text ?text
- tempo-unit ?unit
- metronome-count ?count)
- (music 'ContextSpeccedMusic
- element (music 'PropertySet
- symbol 'tempoWholesPerMinute)))))
- (format #f "\\tempo ~{~a~a~}~a = ~a~a"
- (if (markup? ?text)
- (list (markup->lily-string ?text) " ")
- '())
- (duration->lily-string ?unit #:force-duration #t)
- (if (pair? ?count)
- (format #f "~a ~~ ~a" (car ?count) (cdr ?count))
- ?count)
- (new-line->lily-string))))
+ elements ((music 'TempoChangeEvent
+ text ?text
+ tempo-unit ?unit
+ metronome-count ?count)
+ (music 'ContextSpeccedMusic
+ element (music 'PropertySet
+ symbol 'tempoWholesPerMinute)))))
+ (format #f "\\tempo ~{~a~a~}~a = ~a~a"
+ (if (markup? ?text)
+ (list (markup->lily-string ?text) " ")
+ '())
+ (duration->lily-string ?unit #:force-duration #t)
+ (if (pair? ?count)
+ (format #f "~a ~~ ~a" (car ?count) (cdr ?count))
+ ?count)
+ (new-line->lily-string))))
(define-display-method TempoChangeEvent (expr parser)
(let ((text (ly:music-property expr 'text)))
(format #f "\\tempo ~a~a"
- (markup->lily-string text)
- (new-line->lily-string))))
+ (markup->lily-string text)
+ (new-line->lily-string))))
;;; \clef
(define clef-name-alist #f)
"If @var{expr} is a clef change, return \"\\clef ...\".
Otherwise, return @code{#f}."
(with-music-match (expr (music 'ContextSpeccedMusic
- context-type 'Staff
- element (music 'SequentialMusic
- elements ((music 'PropertySet
- value ?clef-glyph
- symbol 'clefGlyph)
- (music 'PropertySet
- symbol 'middleCClefPosition)
- (music 'PropertySet
- value ?clef-position
- symbol 'clefPosition)
- (music 'PropertySet
- value ?clef-transposition
- symbol 'clefTransposition)
- (music 'ApplyContext
- procedure ly:set-middle-C!)))))
- (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0)
- clef-name-alist)))
- (if clef-name
- (format #f "\\clef \"~a~{~a~a~}\"~a"
- clef-name
- (cond ((= 0 ?clef-transposition)
- (list "" ""))
- ((> ?clef-transposition 0)
- (list "^" (1+ ?clef-transposition)))
- (else
- (list "_" (- 1 ?clef-transposition))))
- (new-line->lily-string))
- #f))))
+ context-type 'Staff
+ element (music 'SequentialMusic
+ elements ((music 'PropertySet
+ value ?clef-glyph
+ symbol 'clefGlyph)
+ (music 'PropertySet
+ symbol 'middleCClefPosition)
+ (music 'PropertySet
+ value ?clef-position
+ symbol 'clefPosition)
+ (music 'PropertySet
+ value ?clef-transposition
+ symbol 'clefTransposition)
+ (music 'ApplyContext
+ procedure ly:set-middle-C!)))))
+ (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0)
+ clef-name-alist)))
+ (if clef-name
+ (format #f "\\clef \"~a~{~a~a~}\"~a"
+ clef-name
+ (cond ((= 0 ?clef-transposition)
+ (list "" ""))
+ ((> ?clef-transposition 0)
+ (list "^" (1+ ?clef-transposition)))
+ (else
+ (list "_" (- 1 ?clef-transposition))))
+ (new-line->lily-string))
+ #f))))
;;; \bar
(define-extra-display-method ContextSpeccedMusic (expr parser)
"If `expr' is a bar, return \"\\bar ...\".
Otherwise, return #f."
(with-music-match (expr (music 'ContextSpeccedMusic
- context-type 'Timing
- element (music 'PropertySet
- value ?bar-type
- symbol 'whichBar)))
- (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
+ context-type 'Timing
+ element (music 'PropertySet
+ value ?bar-type
+ symbol 'whichBar)))
+ (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
;;; \partial
(define-extra-display-method ContextSpeccedMusic (expr parser)
"If `expr' is a partial measure, return \"\\partial ...\".
Otherwise, return #f."
(with-music-match (expr (music
- 'ContextSpeccedMusic
- element (music
- 'ContextSpeccedMusic
- context-type 'Timing
- element (music
- 'PartialSet
- partial-duration ?duration))))
-
- (and ?duration
- (format #f "\\partial ~a"
- (duration->lily-string ?duration #:force-duration #t)))))
+ 'ContextSpeccedMusic
+ element (music
+ 'ContextSpeccedMusic
+ context-type 'Timing
+ element (music
+ 'PartialSet
+ partial-duration ?duration))))
+
+ (and ?duration
+ (format #f "\\partial ~a"
+ (duration->lily-string ?duration #:force-duration #t)))))
;;;
;;;
(define-display-method ApplyOutputEvent (applyoutput parser)
(let ((proc (ly:music-property applyoutput 'procedure))
- (ctx (ly:music-property applyoutput 'context-type)))
+ (ctx (ly:music-property applyoutput 'context-type)))
(format #f "\\applyOutput #'~a #~a"
- ctx
- (or (procedure-name proc)
- (with-output-to-string
- (lambda ()
- (pretty-print (procedure-source proc))))))))
+ ctx
+ (or (procedure-name proc)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source proc))))))))
(define-display-method ApplyContext (applycontext parser)
(let ((proc (ly:music-property applycontext 'procedure)))
(format #f "\\applyContext #~a"
- (or (procedure-name proc)
- (with-output-to-string
- (lambda ()
- (pretty-print (procedure-source proc))))))))
+ (or (procedure-name proc)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source proc))))))))
;;; \partcombine
(define-display-method PartCombineMusic (expr parser)
(format #f "\\partcombine ~{~a ~}"
- (map-in-order (lambda (music)
- (music->lily-string music parser))
- (ly:music-property expr 'elements))))
+ (map-in-order (lambda (music)
+ (music->lily-string music parser))
+ (ly:music-property expr 'elements))))
(define-extra-display-method PartCombineMusic (expr parser)
(with-music-match (expr (music 'PartCombineMusic
- elements ((music 'UnrelativableMusic
- element (music 'ContextSpeccedMusic
- context-id "one"
- context-type 'Voice
- element ?sequence1))
- (music 'UnrelativableMusic
- element (music 'ContextSpeccedMusic
- context-id "two"
- context-type 'Voice
- element ?sequence2)))))
- (format #f "\\partcombine ~a~a~a"
- (music->lily-string ?sequence1 parser)
- (new-line->lily-string)
- (music->lily-string ?sequence2 parser))))
+ elements ((music 'UnrelativableMusic
+ element (music 'ContextSpeccedMusic
+ context-id "one"
+ context-type 'Voice
+ element ?sequence1))
+ (music 'UnrelativableMusic
+ element (music 'ContextSpeccedMusic
+ context-id "two"
+ context-type 'Voice
+ element ?sequence2)))))
+ (format #f "\\partcombine ~a~a~a"
+ (music->lily-string ?sequence1 parser)
+ (new-line->lily-string)
+ (music->lily-string ?sequence2 parser))))
(define-display-method UnrelativableMusic (expr parser)
(music->lily-string (ly:music-property expr 'element) parser))
;;; Cue notes
(define-display-method QuoteMusic (expr parser)
(or (with-music-match (expr (music
- 'QuoteMusic
- quoted-voice-direction ?quoted-voice-direction
- quoted-music-name ?quoted-music-name
- quoted-context-id "cue"
- quoted-context-type 'Voice
- element ?music))
- (format #f "\\cueDuring #~s #~a ~a"
- ?quoted-music-name
- ?quoted-voice-direction
- (music->lily-string ?music parser)))
+ 'QuoteMusic
+ quoted-voice-direction ?quoted-voice-direction
+ quoted-music-name ?quoted-music-name
+ quoted-context-id "cue"
+ quoted-context-type 'Voice
+ element ?music))
+ (format #f "\\cueDuring #~s #~a ~a"
+ ?quoted-music-name
+ ?quoted-voice-direction
+ (music->lily-string ?music parser)))
(format #f "\\quoteDuring #~s ~a"
- (ly:music-property expr 'quoted-music-name)
- (music->lily-string (ly:music-property expr 'element) parser))))
+ (ly:music-property expr 'quoted-music-name)
+ (music->lily-string (ly:music-property expr 'element) parser))))
;;;
;;; Breaks
(define-extra-display-method EventChord (expr parser)
(with-music-match (expr (music 'EventChord
- elements ((music 'LineBreakEvent
- break-permission 'force)
- (music 'PageBreakEvent
- break-permission 'force))))
- "\\pageBreak"))
+ elements ((music 'LineBreakEvent
+ break-permission 'force)
+ (music 'PageBreakEvent
+ break-permission 'force))))
+ "\\pageBreak"))
(define-extra-display-method EventChord (expr parser)
(with-music-match (expr (music 'EventChord
- elements ((music 'LineBreakEvent
- break-permission 'force)
- (music 'PageBreakEvent
- break-permission 'force)
- (music 'PageTurnEvent
- break-permission 'force))))
- "\\pageTurn"))
+ elements ((music 'LineBreakEvent
+ break-permission 'force)
+ (music 'PageBreakEvent
+ break-permission 'force)
+ (music 'PageTurnEvent
+ break-permission 'force))))
+ "\\pageTurn"))
;;;
;;; Lyrics
;;; \lyricsto
(define-display-method LyricCombineMusic (expr parser)
(format #f "\\lyricsto ~s ~a"
- (ly:music-property expr 'associated-context)
- (parameterize ((*explicit-mode* #f))
- (music->lily-string (ly:music-property expr 'element) parser))))
+ (ly:music-property expr 'associated-context)
+ (parameterize ((*explicit-mode* #f))
+ (music->lily-string (ly:music-property expr 'element) parser))))
;; \addlyrics
(define-extra-display-method SimultaneousMusic (expr parser)
(with-music-match (expr (music 'SimultaneousMusic
- elements ((music 'ContextSpeccedMusic
- context-id ?id
- context-type 'Voice
- element ?note-sequence)
- (music 'ContextSpeccedMusic
- context-type 'Lyrics
- create-new #t
- element (music 'LyricCombineMusic
- associated-context ?associated-id
- element ?lyric-sequence)))))
- (if (string=? ?id ?associated-id)
- (format #f "~a~a \\addlyrics ~a"
- (music->lily-string ?note-sequence parser)
- (new-line->lily-string)
- (parameterize ((*explicit-mode* #f))
- (music->lily-string ?lyric-sequence parser)))
- #f)))
+ elements ((music 'ContextSpeccedMusic
+ context-id ?id
+ context-type 'Voice
+ element ?note-sequence)
+ (music 'ContextSpeccedMusic
+ context-type 'Lyrics
+ create-new #t
+ element (music 'LyricCombineMusic
+ associated-context ?associated-id
+ element ?lyric-sequence)))))
+ (if (string=? ?id ?associated-id)
+ (format #f "~a~a \\addlyrics ~a"
+ (music->lily-string ?note-sequence parser)
+ (new-line->lily-string)
+ (parameterize ((*explicit-mode* #f))
+ (music->lily-string ?lyric-sequence parser)))
+ #f)))
;; Silence internal event sent at end of each lyrics block
(define-display-method CompletizeExtenderEvent (expr parser)
(lambda (x) (apply music-property-description x))
`(
(absolute-octave ,integer?
- "The absolute octave for a octave check note.")
+ "The absolute octave for a octave check note.")
(alteration ,number? "Alteration for figured bass.")
(alternative-dir ,ly:dir? "Indicates if an AlternativeMusic is the
First (-1), Middle (0), or Last (1) of group of alternate endings.")
TODO: Consider making type into symbol.")
(articulations ,ly:music-list?
- "Articulation events specifically for this note.")
+ "Articulation events specifically for this note.")
(associated-context ,string? "Name of the Voice context associated with
this @code{\\lyricsto} section.")
(augmented ,boolean? "This figure is for an augmented figured
(bracket-stop ,boolean? "Stop a bracket here.")
(break-penalty ,number? "Penalty for line break hint.")
(break-permission ,symbol?
- "Whether to allow, forbid or force a line break.")
+ "Whether to allow, forbid or force a line break.")
(cautionary ,boolean? "If set, this alteration needs a
cautionary accidental.")
(elements-callback ,procedure? "Return a list of children, for use by
a sequential iterator. Takes a single music parameter.")
(error-found ,boolean?
- "If true, a parsing error was found in this expression.")
+ "If true, a parsing error was found in this expression.")
(events ,list? "A list of events contained in this event.")
(figure ,integer? "A bass figure.")
FIXME: Naming.")
(X-offset ,number?
- "Offset of resulting grob; only used for balloon texts.")
+ "Offset of resulting grob; only used for balloon texts.")
(Y-offset ,number?
- "Offset of resulting grob; only used for balloon texts.")
- )))
+ "Offset of resulting grob; only used for balloon texts.")
+ )))
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 1998--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
-;;;; Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Jan Nieuwenhuizen <janneke@gnu.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
Syntax: @var{note}@code{\\x}, where @code{\\x} is a dynamic mark like
@code{\\ppp} or @code{\\sfz}. A complete list is in file
@file{ly/@/dynamic-scripts-init.ly}.")
- (types . (general-music post-event event dynamic-event absolute-dynamic-event))
- ))
+ (types . (general-music post-event event dynamic-event absolute-dynamic-event))
+ ))
(AlternativeEvent
. ((description . "Create a alternative event.")
(types . (general-music event alternative-event))
- ))
+ ))
(AnnotateOutputEvent
. ((description . "Print an annotation of an output element.")
- (types . (general-music event annotate-output-event post-event))
- ))
+ (types . (general-music event annotate-output-event post-event))
+ ))
(ApplyContext
. ((description . "Call the argument with the current context during
interpreting phase.")
- (types . (general-music apply-context))
- (iterator-ctor . ,ly:apply-context-iterator::constructor)
- ))
+ (types . (general-music apply-context))
+ (iterator-ctor . ,ly:apply-context-iterator::constructor)
+ ))
(ApplyOutputEvent
. ((description . "Call the argument with all current grobs during
Arguments to @var{func} are 1.@tie{}the grob, 2.@tie{}the originating
context, and 3.@tie{}the context where @var{func} is called.")
- (types . (general-music event apply-output-event))
- ))
+ (types . (general-music event apply-output-event))
+ ))
(ArpeggioEvent
. ((description . "Make an arpeggio on this note.
Syntax: @w{@var{note}@code{-\\arpeggio}}")
- (types . (general-music post-event arpeggio-event event))
- ))
+ (types . (general-music post-event arpeggio-event event))
+ ))
;; todo: use articulation-event for slur as well.
;; separate non articulation scripts
\n(no direction specified), and where @code{y} is an articulation\
\n(such as @w{@code{-.}}, @w{@code{->}}, @code{\\tenuto}, @code{\\downbow}).
See the Notation Reference for details.")
- (types . (general-music post-event event articulation-event script-event))
- ))
+ (types . (general-music post-event event articulation-event script-event))
+ ))
(AutoChangeMusic
. ((description . "Used for making voices that switch between
piano staves automatically.")
- (iterator-ctor . ,ly:auto-change-iterator::constructor)
- (start-callback . ,ly:music-wrapper::start-callback)
- (length-callback . ,ly:music-wrapper::length-callback)
- (types . (general-music music-wrapper-music auto-change-instruction))
- ))
+ (iterator-ctor . ,ly:auto-change-iterator::constructor)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (types . (general-music music-wrapper-music auto-change-instruction))
+ ))
(BarCheck
. ((description . "Check whether this music coincides with
the start of the measure.")
- (types . (general-music bar-check))
- (iterator-ctor . ,ly:bar-check-iterator::constructor)
- ))
+ (types . (general-music bar-check))
+ (iterator-ctor . ,ly:bar-check-iterator::constructor)
+ ))
(BassFigureEvent
. ((description . "Print a bass-figure text.")
- (types . (general-music event rhythmic-event bass-figure-event))
- ))
+ (types . (general-music event rhythmic-event bass-figure-event))
+ ))
(BeamEvent
. ((description . "Start or stop a beam.
Syntax for manual control: @code{c8-[ c c-] c8}")
- (types . (general-music post-event event beam-event span-event))
- ))
+ (types . (general-music post-event event beam-event span-event))
+ ))
(BeamForbidEvent
. ((description . "Specify that a note may not auto-beamed.")
- (types . (general-music post-event event beam-forbid-event))
- ))
+ (types . (general-music post-event event beam-forbid-event))
+ ))
(BreakDynamicSpanEvent
. ((description . "End an alignment spanner for dynamics here.")
- (types . (general-music post-event break-span-event break-dynamic-span-event event))
- ))
+ (types . (general-music post-event break-span-event break-dynamic-span-event event))
+ ))
(BendAfterEvent
. ((description . "A drop/@/fall/@/doit jazz articulation.")
- (types . (general-music post-event bend-after-event event))))
+ (types . (general-music post-event bend-after-event event))))
(BreathingEvent
. ((description . "Create a @q{breath mark} or @q{comma}.
Syntax: @var{note}@code{\\breathe}")
- (types . (general-music event breathing-event))
- ))
+ (types . (general-music event breathing-event))
+ ))
(ClusterNoteEvent
. ((description . "A note that is part of a cluster.")
- ;; not a note-event, to ensure that Note_heads_engraver doesn't eat it.
- (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
- (types . (general-music cluster-note-event melodic-event
- rhythmic-event event))
- ))
+ ;; not a note-event, to ensure that Note_heads_engraver doesn't eat it.
+ (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
+ (types . (general-music cluster-note-event melodic-event
+ rhythmic-event event))
+ ))
(CompletizeExtenderEvent
. ((description . "Used internally to signal the end of a lyrics block to
ensure extenders are completed correctly when a @code{Lyrics} context ends
before its associated @code{Voice} context.")
- (types . (general-music completize-extender-event event))
- ))
+ (types . (general-music completize-extender-event event))
+ ))
(ContextChange
. ((description . "Change staves in Piano staff.
Syntax: @code{\\change Staff = @var{new-id}}")
- (iterator-ctor . ,ly:change-iterator::constructor)
- (types . (general-music translator-change-instruction))
- ))
+ (iterator-ctor . ,ly:change-iterator::constructor)
+ (types . (general-music translator-change-instruction))
+ ))
(ContextSpeccedMusic
. ((description . "Interpret the argument music within a
specific context.")
- (iterator-ctor . ,ly:context-specced-music-iterator::constructor)
- (length-callback . ,ly:music-wrapper::length-callback)
- (start-callback . ,ly:music-wrapper::start-callback)
- (types . (context-specification general-music music-wrapper-music))
- ))
+ (iterator-ctor . ,ly:context-specced-music-iterator::constructor)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (types . (context-specification general-music music-wrapper-music))
+ ))
(CrescendoEvent
. ((description . "Begin or end a crescendo.
An alternative syntax is @var{note}@code{\\cr} @dots{}
@var{note}@code{\\endcr}.")
- (types . (general-music post-event span-event span-dynamic-event crescendo-event
- event))
- ))
+ (types . (general-music post-event span-event span-dynamic-event crescendo-event
+ event))
+ ))
(DecrescendoEvent
. ((description . "Begin or end a decrescendo.
An alternative syntax is @var{note}@code{\\decr} @dots{}
@var{note}@code{\\enddecr}.")
- (types . (general-music post-event span-event span-dynamic-event decrescendo-event
- event))
- ))
+ (types . (general-music post-event span-event span-dynamic-event decrescendo-event
+ event))
+ ))
(DoublePercentEvent
. ((description . "Used internally to signal double percent repeats.")
- (types . (general-music event double-percent-event rhythmic-event))
- ))
+ (types . (general-music event double-percent-event rhythmic-event))
+ ))
(EpisemaEvent
. ((description . "Begin or end an episema.")
- (types . (general-music post-event span-event event episema-event))
- ))
+ (types . (general-music post-event span-event event episema-event))
+ ))
(Event
. ((description . "Atomic music event.")
- (types . (general-music event))
- ))
+ (types . (general-music event))
+ ))
(EventChord
. ((description . "Explicitly entered chords.
An unexpanded chord repetition @samp{q} is recognizable by having its
duration stored in @code{duration}.")
- (iterator-ctor . ,ly:event-chord-iterator::constructor)
- (length-callback . ,ly:music-sequence::event-chord-length-callback)
- (to-relative-callback .
- ,ly:music-sequence::event-chord-relative-callback)
- (types . (general-music event-chord simultaneous-music))
- ))
+ (iterator-ctor . ,ly:event-chord-iterator::constructor)
+ (length-callback . ,ly:music-sequence::event-chord-length-callback)
+ (to-relative-callback .
+ ,ly:music-sequence::event-chord-relative-callback)
+ (types . (general-music event-chord simultaneous-music))
+ ))
(ExtenderEvent
. ((description . "Extend lyrics.")
- (types . (general-music post-event extender-event event))
- ))
+ (types . (general-music post-event extender-event event))
+ ))
(FingeringEvent
. ((description . "Specify what finger to use for this note.")
- (types . (general-music post-event fingering-event event))
- ))
+ (types . (general-music post-event fingering-event event))
+ ))
(FootnoteEvent
. ((description . "Footnote a grob.")
- (types . (general-music event footnote-event))
- ))
+ (types . (general-music event footnote-event))
+ ))
(GlissandoEvent
. ((description . "Start a glissando on this note.")
- (types . (general-music post-event glissando-event event))
- ))
+ (types . (general-music post-event glissando-event event))
+ ))
(GraceMusic
. ((description . "Interpret the argument as grace notes.")
- (start-callback . ,ly:grace-music::start-callback)
- (length . ,ZERO-MOMENT)
- (iterator-ctor . ,ly:grace-iterator::constructor)
- (types . (grace-music music-wrapper-music general-music))
- ))
+ (start-callback . ,ly:grace-music::start-callback)
+ (length . ,ZERO-MOMENT)
+ (iterator-ctor . ,ly:grace-iterator::constructor)
+ (types . (grace-music music-wrapper-music general-music))
+ ))
(HarmonicEvent
. ((description . "Mark a note as harmonic.")
- (types . (general-music post-event event harmonic-event))
- ))
+ (types . (general-music post-event event harmonic-event))
+ ))
(HyphenEvent
. ((description . "A hyphen between lyric syllables.")
- (types . (general-music post-event hyphen-event event))
- ))
+ (types . (general-music post-event hyphen-event event))
+ ))
(KeyChangeEvent
. ((description . "Change the key signature.
Syntax: @code{\\key} @var{name} @var{scale}")
- (to-relative-callback . ,(lambda (x p) p))
- (types . (general-music key-change-event event))
- ))
+ (to-relative-callback . ,(lambda (x p) p))
+ (types . (general-music key-change-event event))
+ ))
(LabelEvent
. ((description . "Place a bookmarking label.")
- (types . (general-music label-event event))
- ))
+ (types . (general-music label-event event))
+ ))
(LaissezVibrerEvent
. ((description . "Don't damp this chord.
Syntax: @var{note}@code{\\laissezVibrer}")
- (types . (general-music post-event event laissez-vibrer-event))
- ))
+ (types . (general-music post-event event laissez-vibrer-event))
+ ))
(LigatureEvent
. ((description . "Start or end a ligature.")
- (types . (general-music span-event ligature-event event))
- ))
+ (types . (general-music span-event ligature-event event))
+ ))
(LineBreakEvent
. ((description . "Allow, forbid or force a line break.")
- (types . (general-music line-break-event break-event event))
- ))
+ (types . (general-music line-break-event break-event event))
+ ))
(LyricCombineMusic
. ((description . "Align lyrics to the start of notes.
Syntax: @code{\\lyricsto} @var{voicename} @var{lyrics}")
- (length . ,ZERO-MOMENT)
- (types . (general-music lyric-combine-music))
- (iterator-ctor . ,ly:lyric-combine-music-iterator::constructor)
- ))
+ (length . ,ZERO-MOMENT)
+ (types . (general-music lyric-combine-music))
+ (iterator-ctor . ,ly:lyric-combine-music-iterator::constructor)
+ ))
(LyricEvent
. ((description . "A lyric syllable. Must be entered in lyrics mode,
i.e., @code{\\lyrics @{ twinkle4 twinkle4 @} }.")
- (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
- (types . (general-music rhythmic-event lyric-event event))
- ))
+ (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
+ (types . (general-music rhythmic-event lyric-event event))
+ ))
(MarkEvent
. ((description . "Insert a rehearsal mark.
Syntax: @code{\\mark} @var{marker}
Example: @code{\\mark \"A\"}")
- (types . (general-music mark-event event))
- ))
+ (types . (general-music mark-event event))
+ ))
(MeasureCounterEvent
. ((description . "Used to signal the start and end of a measure count.")
(MultiMeasureRestEvent
. ((description . "Used internally by @code{MultiMeasureRestMusic}
to signal rests.")
- (types . (general-music event rhythmic-event
- multi-measure-rest-event))
- ))
+ (types . (general-music event rhythmic-event
+ multi-measure-rest-event))
+ ))
(MultiMeasureRestMusic
. ((description . "Rests that may be compressed into Multi rests.
Syntax: @code{R2.*4} for 4 measures in 3/4 time.")
- (iterator-ctor . ,ly:sequential-iterator::constructor)
- (elements-callback . ,mm-rest-child-list)
- (types . (general-music multi-measure-rest))
- ))
+ (iterator-ctor . ,ly:sequential-iterator::constructor)
+ (elements-callback . ,mm-rest-child-list)
+ (types . (general-music multi-measure-rest))
+ ))
(MultiMeasureTextEvent
. ((description . "Texts on multi measure rests.
Syntax: @code{R-\\markup @{ \\roman \"bla\" @}}
Note the explicit font switch.")
- (types . (general-music post-event event multi-measure-text-event))
- ))
+ (types . (general-music post-event event multi-measure-text-event))
+ ))
(Music
. ((description . "Generic type for music expressions.")
- (types . (general-music))
- ))
+ (types . (general-music))
+ ))
(NoteEvent
. ((description . "A note.
are broadcast like chord articulations, the others are retained.
For iteration inside of chords, @xref{EventChord}.")
- (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
- (types . (general-music event note-event rhythmic-event
- melodic-event))
- ))
+ (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
+ (types . (general-music event note-event rhythmic-event
+ melodic-event))
+ ))
(NoteGroupingEvent
. ((description . "Start or stop grouping brackets.")
- (types . (general-music post-event event note-grouping-event))
- ))
+ (types . (general-music post-event event note-grouping-event))
+ ))
(OttavaMusic
. ((description . "Start or stop an ottava bracket.")
- (iterator-ctor . ,ly:sequential-iterator::constructor)
- (elements-callback . ,make-ottava-set)
- (types . (general-music ottava-music))
- ))
+ (iterator-ctor . ,ly:sequential-iterator::constructor)
+ (elements-callback . ,make-ottava-set)
+ (types . (general-music ottava-music))
+ ))
(OverrideProperty
. ((description . "Extend the definition of a graphical object.
Syntax: @code{\\override} [ @var{context} @code{.} ]
@var{object} @var{property} @code{=} @var{value}")
- (types . (general-music layout-instruction-event
- override-property-event))
- (iterator-ctor . ,ly:push-property-iterator::constructor)
- (untransposable . #t)
- ))
+ (types . (general-music layout-instruction-event
+ override-property-event))
+ (iterator-ctor . ,ly:push-property-iterator::constructor)
+ (untransposable . #t)
+ ))
(PageBreakEvent
. ((description . "Allow, forbid or force a page break.")
- (types . (general-music break-event page-break-event event))
- ))
+ (types . (general-music break-event page-break-event event))
+ ))
(PageTurnEvent
. ((description . "Allow, forbid or force a page turn.")
- (types . (general-music break-event page-turn-event event))
- ))
+ (types . (general-music break-event page-turn-event event))
+ ))
(PartCombineForceEvent
. ((description . "Override the part-combiner's strategy.")
- (types . (general-music part-combine-force-event event))
- ))
+ (types . (general-music part-combine-force-event event))
+ ))
(PartialSet
. ((description . "Create an anacrusis or upbeat (partial measure).")
- (iterator-ctor . ,ly:partial-iterator::constructor)
- (types . (general-music partial-set))
+ (iterator-ctor . ,ly:partial-iterator::constructor)
+ (types . (general-music partial-set))
))
(PartCombineMusic
. ((description . "Combine two parts on a staff, either merged or
as separate voices.")
- (length-callback . ,ly:music-sequence::maximum-length-callback)
- (start-callback . ,ly:music-sequence::minimum-start-callback)
- (types . (general-music part-combine-music))
- (iterator-ctor . ,ly:part-combine-iterator::constructor)
- ))
+ (length-callback . ,ly:music-sequence::maximum-length-callback)
+ (start-callback . ,ly:music-sequence::minimum-start-callback)
+ (types . (general-music part-combine-music))
+ (iterator-ctor . ,ly:part-combine-iterator::constructor)
+ ))
(PercentEvent
. ((description . "Used internally to signal percent repeats.")
- (types . (general-music event percent-event rhythmic-event))
- ))
+ (types . (general-music event percent-event rhythmic-event))
+ ))
(PercentRepeatedMusic
. ((description . "Repeats encoded by percents and slashes.")
- (iterator-ctor . ,ly:percent-repeat-iterator::constructor)
- (start-callback . ,ly:repeated-music::first-start)
- (length-callback . ,ly:repeated-music::unfolded-music-length)
- (types . (general-music repeated-music percent-repeated-music))
- ))
+ (iterator-ctor . ,ly:percent-repeat-iterator::constructor)
+ (start-callback . ,ly:repeated-music::first-start)
+ (length-callback . ,ly:repeated-music::unfolded-music-length)
+ (types . (general-music repeated-music percent-repeated-music))
+ ))
(PesOrFlexaEvent
. ((description . "Within a ligature, mark the previous and the
following note to form a pes (if melody goes up) or a flexa (if melody
goes down).")
- (types . (general-music pes-or-flexa-event event))
- ))
+ (types . (general-music pes-or-flexa-event event))
+ ))
(PhrasingSlurEvent
. ((description . "Start or end phrasing slur.
Syntax: @var{note}@code{\\(} and @var{note}@code{\\)}")
(spanner-id . "")
- (types . (general-music post-event span-event event phrasing-slur-event))
- ))
+ (types . (general-music post-event span-event event phrasing-slur-event))
+ ))
(PostEvents
. ((description . "Container for several postevents.
. ((description . "Set a context property.
Syntax: @code{\\set @var{context}.@var{prop} = @var{scheme-val}}")
- (types . (layout-instruction-event general-music))
- (iterator-ctor . ,ly:property-iterator::constructor)
- (untransposable . #t)
- ))
+ (types . (layout-instruction-event general-music))
+ (iterator-ctor . ,ly:property-iterator::constructor)
+ (untransposable . #t)
+ ))
(PropertyUnset
. ((description . "Restore the default setting for a context
property. See @ref{PropertySet}.
Syntax: @code{\\unset @var{context}.@var{prop}}")
- (types . (layout-instruction-event general-music))
- (iterator-ctor . ,ly:property-unset-iterator::constructor)
- ))
+ (types . (layout-instruction-event general-music))
+ (iterator-ctor . ,ly:property-unset-iterator::constructor)
+ ))
(QuoteMusic
. ((description . "Quote preprocessed snippets of music.")
- (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
- (length-callback . ,ly:music-wrapper::length-callback)
- (start-callback . ,ly:music-wrapper::start-callback)
- (types . (general-music music-wrapper-music))
- ))
+ (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (types . (general-music music-wrapper-music))
+ ))
(RelativeOctaveCheck
. ((description . "Check if a pitch is in the correct octave.")
- (to-relative-callback . ,ly:relative-octave-check::relative-callback)
- (types . (general-music relative-octave-check))
- ))
+ (to-relative-callback . ,ly:relative-octave-check::relative-callback)
+ (types . (general-music relative-octave-check))
+ ))
(RelativeOctaveMusic
. ((description . "Music that was entered in relative octave notation.")
- (to-relative-callback . ,ly:relative-octave-music::relative-callback)
- (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
- (length-callback . ,ly:music-wrapper::length-callback)
- (start-callback . ,ly:music-wrapper::start-callback)
- (types . (music-wrapper-music general-music relative-octave-music))
- ))
+ (to-relative-callback . ,ly:relative-octave-music::relative-callback)
+ (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (types . (music-wrapper-music general-music relative-octave-music))
+ ))
(RepeatedMusic
. ((description . "Repeat music in different ways.")
- (types . (general-music repeated-music))
- ))
+ (types . (general-music repeated-music))
+ ))
(RepeatSlashEvent
. ((description . "Used internally to signal beat repeats.")
- (types . (general-music event repeat-slash-event rhythmic-event))
- ))
+ (types . (general-music event repeat-slash-event rhythmic-event))
+ ))
(RepeatTieEvent
. ((description . "Ties for starting a second volta bracket.")
- (types . (general-music post-event event repeat-tie-event))
- ))
+ (types . (general-music post-event event repeat-tie-event))
+ ))
(RestEvent
. ((description . "A Rest.
Syntax: @code{r4} for a quarter rest.")
- (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
- (types . (general-music event rhythmic-event rest-event))
- ))
+ (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
+ (types . (general-music event rhythmic-event rest-event))
+ ))
(RevertProperty
. ((description . "The opposite of @ref{OverrideProperty}: remove a
previously added property from a graphical object definition.")
- (types . (general-music layout-instruction-event))
- (iterator-ctor . ,ly:pop-property-iterator::constructor)
- ))
+ (types . (general-music layout-instruction-event))
+ (iterator-ctor . ,ly:pop-property-iterator::constructor)
+ ))
(ScriptEvent
. ((description . "Add an articulation mark to a note.")
- (types . (general-music event))
- ))
+ (types . (general-music event))
+ ))
(SequentialMusic
. ((description . "Music expressions concatenated.
Syntax: @code{\\sequential @{ @dots{} @}} or simply @code{@{ @dots{} @}}")
- (length-callback . ,ly:music-sequence::cumulative-length-callback)
- (start-callback . ,ly:music-sequence::first-start-callback)
- (elements-callback . ,(lambda (m) (ly:music-property m 'elements)))
- (iterator-ctor . ,ly:sequential-iterator::constructor)
- (types . (general-music sequential-music))
- ))
+ (length-callback . ,ly:music-sequence::cumulative-length-callback)
+ (start-callback . ,ly:music-sequence::first-start-callback)
+ (elements-callback . ,(lambda (m) (ly:music-property m 'elements)))
+ (iterator-ctor . ,ly:sequential-iterator::constructor)
+ (types . (general-music sequential-music))
+ ))
(SimultaneousMusic
. ((description . "Music playing together.
Syntax: @code{\\simultaneous @{ @dots{} @}} or @code{<< @dots{} >>}")
- (iterator-ctor . ,ly:simultaneous-music-iterator::constructor)
- (start-callback . ,ly:music-sequence::minimum-start-callback)
- (length-callback . ,ly:music-sequence::maximum-length-callback)
- (to-relative-callback .
- ,ly:music-sequence::simultaneous-relative-callback)
- (types . (general-music simultaneous-music))
- ))
+ (iterator-ctor . ,ly:simultaneous-music-iterator::constructor)
+ (start-callback . ,ly:music-sequence::minimum-start-callback)
+ (length-callback . ,ly:music-sequence::maximum-length-callback)
+ (to-relative-callback .
+ ,ly:music-sequence::simultaneous-relative-callback)
+ (types . (general-music simultaneous-music))
+ ))
(SkipEvent
. ((description . "Filler that takes up duration, but does not
print anything.
Syntax: @code{s4} for a skip equivalent to a quarter rest.")
- (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
- (types . (general-music event rhythmic-event skip-event))
- ))
+ (iterator-ctor . ,ly:rhythmic-music-iterator::constructor)
+ (types . (general-music event rhythmic-event skip-event))
+ ))
(SkipMusic
. ((description . "Filler that takes up duration, does not
print anything, and also does not create staves or voices implicitly.
Syntax: @code{\\skip} @var{duration}")
- (length-callback . ,ly:music-duration-length)
- (iterator-ctor . ,ly:simple-music-iterator::constructor)
- (types . (general-music event skip-event))
- ))
+ (length-callback . ,ly:music-duration-length)
+ (iterator-ctor . ,ly:simple-music-iterator::constructor)
+ (types . (general-music event skip-event))
+ ))
(SlurEvent
. ((description . "Start or end slur.
Syntax: @var{note}@code{(} and @var{note}@code{)}")
(spanner-id . "")
- (types . (general-music post-event span-event event slur-event))
- ))
+ (types . (general-music post-event span-event event slur-event))
+ ))
(SoloOneEvent
. ((description . "Print @q{Solo@tie{}1}.")
- (part-combine-status . solo1)
- (types . (general-music event part-combine-event solo-one-event))
- ))
+ (part-combine-status . solo1)
+ (types . (general-music event part-combine-event solo-one-event))
+ ))
(SoloTwoEvent
. ((description . "Print @q{Solo@tie{}2}.")
- (part-combine-status . solo2)
- (types . (general-music event part-combine-event solo-two-event))
- ))
+ (part-combine-status . solo2)
+ (types . (general-music event part-combine-event solo-two-event))
+ ))
(SostenutoEvent
. ((description . "Depress or release sostenuto pedal.")
- (types . (general-music post-event event pedal-event sostenuto-event))
- ))
+ (types . (general-music post-event event pedal-event sostenuto-event))
+ ))
(SpacingSectionEvent
. ((description . "Start a new spacing section.")
- (types . (general-music event spacing-section-event))))
+ (types . (general-music event spacing-section-event))))
(SpanEvent
. ((description . "Event for anything that is started at a
different time than stopped.")
- (types . (general-music event))
- ))
+ (types . (general-music event))
+ ))
(StaffSpanEvent
. ((description . "Start or stop a staff symbol.")
- (types . (general-music event span-event staff-span-event))
- ))
+ (types . (general-music event span-event staff-span-event))
+ ))
(StringNumberEvent
. ((description . "Specify on which string to play this note.
Syntax: @code{\\@var{number}}")
- (types . (general-music post-event string-number-event event))
- ))
+ (types . (general-music post-event string-number-event event))
+ ))
(StrokeFingerEvent
. ((description . "Specify with which finger to pluck a string.
Syntax: @code{\\rightHandFinger @var{text}}")
- (types . (general-music post-event stroke-finger-event event))
- ))
+ (types . (general-music post-event stroke-finger-event event))
+ ))
(SustainEvent
. ((description . "Depress or release sustain pedal.")
- (types . (general-music post-event event pedal-event sustain-event))
- ))
+ (types . (general-music post-event event pedal-event sustain-event))
+ ))
(TempoChangeEvent
. ((description . "A metronome mark or tempo indication.")
- (types . (general-music event tempo-change-event))
- ))
+ (types . (general-music event tempo-change-event))
+ ))
(TextScriptEvent
. ((description . "Print text.")
- (types . (general-music post-event script-event text-script-event event))
- ))
+ (types . (general-music post-event script-event text-script-event event))
+ ))
(TextSpanEvent
. ((description . "Start a text spanner, for example, an
octavation.")
- (types . (general-music post-event span-event event text-span-event))
- ))
+ (types . (general-music post-event span-event event text-span-event))
+ ))
(TieEvent
. ((description . "A tie.
Syntax: @w{@var{note}@code{-~}}")
- (types . (general-music post-event tie-event event))
- ))
+ (types . (general-music post-event tie-event event))
+ ))
(TimeScaledMusic
. ((description . "Multiply durations, as in tuplets.
Syntax: @code{\\times @var{fraction} @var{music}}, e.g.,
@code{\\times 2/3 @{ @dots{} @}} for triplets.")
- (length-callback . ,ly:music-wrapper::length-callback)
- (start-callback . ,ly:music-wrapper::start-callback)
- (iterator-ctor . ,ly:tuplet-iterator::constructor)
- (types . (time-scaled-music music-wrapper-music general-music))
- ))
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (iterator-ctor . ,ly:tuplet-iterator::constructor)
+ (types . (time-scaled-music music-wrapper-music general-music))
+ ))
(TimeSignatureMusic
. ((description . "Set a new time signature")
(TransposedMusic
. ((description . "Music that has been transposed.")
- (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
- (start-callback . ,ly:music-wrapper::start-callback)
- (length-callback . ,ly:music-wrapper::length-callback)
- (to-relative-callback .
- ,ly:relative-octave-music::no-relative-callback)
- (types . (music-wrapper-music general-music transposed-music))
- ))
+ (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
+ (start-callback . ,ly:music-wrapper::start-callback)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (to-relative-callback .
+ ,ly:relative-octave-music::no-relative-callback)
+ (types . (music-wrapper-music general-music transposed-music))
+ ))
(TremoloEvent
. ((description . "Unmeasured tremolo.")
- (types . (general-music post-event event tremolo-event))
- ))
+ (types . (general-music post-event event tremolo-event))
+ ))
(TremoloRepeatedMusic
. ((description . "Repeated notes denoted by tremolo beams.")
- (iterator-ctor . ,ly:chord-tremolo-iterator::constructor)
- (start-callback . ,ly:repeated-music::first-start)
- ;; the length of the repeat is handled by shifting the note logs
- (length-callback . ,ly:repeated-music::folded-music-length)
- (types . (general-music repeated-music tremolo-repeated-music))
- ))
+ (iterator-ctor . ,ly:chord-tremolo-iterator::constructor)
+ (start-callback . ,ly:repeated-music::first-start)
+ ;; the length of the repeat is handled by shifting the note logs
+ (length-callback . ,ly:repeated-music::folded-music-length)
+ (types . (general-music repeated-music tremolo-repeated-music))
+ ))
(TremoloSpanEvent
. ((description . "Tremolo over two stems.")
- (types . (general-music event span-event tremolo-span-event))
- ))
+ (types . (general-music event span-event tremolo-span-event))
+ ))
(TrillSpanEvent
. ((description . "Start a trill spanner.")
- (types . (general-music post-event span-event event trill-span-event))
- ))
+ (types . (general-music post-event span-event event trill-span-event))
+ ))
(TupletSpanEvent
. ((description . "Used internally to signal where tuplet
brackets start and stop.")
- (types . (tuplet-span-event span-event event general-music post-event))
- ))
+ (types . (tuplet-span-event span-event event general-music post-event))
+ ))
(UnaCordaEvent
. ((description . "Depress or release una-corda pedal.")
- (types . (general-music post-event event pedal-event una-corda-event))
- ))
+ (types . (general-music post-event event pedal-event una-corda-event))
+ ))
(UnfoldedRepeatedMusic
. ((description . "Repeated music which is fully written
(and played) out.")
- (iterator-ctor . ,ly:unfolded-repeat-iterator::constructor)
- (start-callback . ,ly:repeated-music::first-start)
- (types . (general-music repeated-music unfolded-repeated-music))
- (length-callback . ,ly:repeated-music::unfolded-music-length)
- ))
+ (iterator-ctor . ,ly:unfolded-repeat-iterator::constructor)
+ (start-callback . ,ly:repeated-music::first-start)
+ (types . (general-music repeated-music unfolded-repeated-music))
+ (length-callback . ,ly:repeated-music::unfolded-music-length)
+ ))
(UnisonoEvent
. ((description . "Print @q{a@tie{}2}.")
- (part-combine-status . unisono)
- (types . (general-music event part-combine-event unisono-event))))
+ (part-combine-status . unisono)
+ (types . (general-music event part-combine-event unisono-event))))
(UnrelativableMusic
. ((description . "Music that cannot be converted from relative
to absolute notation. For example, transposed music.")
- (to-relative-callback . ,ly:relative-octave-music::no-relative-callback)
- (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
- (length-callback . ,ly:music-wrapper::length-callback)
- (types . (music-wrapper-music general-music unrelativable-music))
- ))
+ (to-relative-callback . ,ly:relative-octave-music::no-relative-callback)
+ (iterator-ctor . ,ly:music-wrapper-iterator::constructor)
+ (length-callback . ,ly:music-wrapper::length-callback)
+ (types . (music-wrapper-music general-music unrelativable-music))
+ ))
(VoiceSeparator
. ((description . "Separate polyphonic voices in simultaneous music.
Syntax: @code{\\\\}")
- (types . (separator general-music))
- ))
+ (types . (separator general-music))
+ ))
(VoltaRepeatedMusic
. ((description . "Repeats with alternatives placed sequentially.")
- (iterator-ctor . ,ly:volta-repeat-iterator::constructor)
- (elements-callback . ,make-volta-set)
- (start-callback . ,ly:repeated-music::first-start)
- (length-callback . ,ly:repeated-music::volta-music-length)
- (types . (general-music repeated-music volta-repeated-music))
- ))
+ (iterator-ctor . ,ly:volta-repeat-iterator::constructor)
+ (elements-callback . ,make-volta-set)
+ (start-callback . ,ly:repeated-music::first-start)
+ (length-callback . ,ly:repeated-music::volta-music-length)
+ (types . (general-music repeated-music volta-repeated-music))
+ ))
))
(set! music-descriptions
(set!
music-descriptions
(map (lambda (x)
- (set-object-property! (car x)
- 'music-description
- (cdr (assq 'description (cdr x))))
- (let ((lst (cdr x)))
- (set! lst (assoc-set! lst 'name (car x)))
- (set! lst (assq-remove! lst 'description))
- (hashq-set! music-name-to-property-table (car x) lst)
- (cons (car x) lst)))
+ (set-object-property! (car x)
+ 'music-description
+ (cdr (assq 'description (cdr x))))
+ (let ((lst (cdr x)))
+ (set! lst (assoc-set! lst 'name (car x)))
+ (set! lst (assq-remove! lst 'description))
+ (hashq-set! music-name-to-property-table (car x) lst)
+ (cons (car x) lst)))
music-descriptions))
(define-safe-public (make-music name . music-properties)
according to @code{music-properties}, a list of alternating property symbols
and values. E.g:
(make-music 'OverrideProperty
- 'symbol 'Stem
- 'grob-property 'thickness
- 'grob-value (* 2 1.5))"
+ 'symbol 'Stem
+ 'grob-property 'thickness
+ 'grob-value (* 2 1.5))"
(if (not (symbol? name))
(ly:error (_ "symbol expected: ~S") name))
(let ((props (hashq-ref music-name-to-property-table name '())))
(if (not (pair? props))
- (ly:error (_ "cannot find music object: ~S") name))
+ (ly:error (_ "cannot find music object: ~S") name))
(let ((m (ly:make-music props)))
(define (set-props mus-props)
- (if (and (not (null? mus-props))
- (not (null? (cdr mus-props))))
- (begin
- (set! (ly:music-property m (car mus-props)) (cadr mus-props))
- (set-props (cddr mus-props)))))
+ (if (and (not (null? mus-props))
+ (not (null? (cdr mus-props))))
+ (begin
+ (set! (ly:music-property m (car mus-props)) (cadr mus-props))
+ (set-props (cddr mus-props)))))
(set-props music-properties)
m)))
(define-public (make-repeated-music name)
(let* ((repeated-music (assoc-get name '(("volta" . VoltaRepeatedMusic)
- ("unfold" . UnfoldedRepeatedMusic)
- ("percent" . PercentRepeatedMusic)
- ("tremolo" . TremoloRepeatedMusic))))
- (repeated-music-name (if repeated-music
- repeated-music
- (begin
- (ly:warning (_ "unknown repeat type `~S'") name)
- (ly:warning (_ "See define-music-types.scm for supported repeats"))
- 'VoltaRepeatedMusic))))
+ ("unfold" . UnfoldedRepeatedMusic)
+ ("percent" . PercentRepeatedMusic)
+ ("tremolo" . TremoloRepeatedMusic))))
+ (repeated-music-name (if repeated-music
+ repeated-music
+ (begin
+ (ly:warning (_ "unknown repeat type `~S'") name)
+ (ly:warning (_ "See define-music-types.scm for supported repeats"))
+ 'VoltaRepeatedMusic))))
(make-music repeated-music-name)))
;; Dutch: c d e f g a b h
(nederlands . (
- (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (ces . ,(ly:make-pitch -1 0 FLAT))
- (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (cis . ,(ly:make-pitch -1 0 SHARP))
- (cih . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
-
- (deh . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (des . ,(ly:make-pitch -1 1 FLAT))
- (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dis . ,(ly:make-pitch -1 1 SHARP))
- (dih . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
-
- (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (ees . ,(ly:make-pitch -1 2 FLAT))
- (eeseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (es . ,(ly:make-pitch -1 2 FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eis . ,(ly:make-pitch -1 2 SHARP))
- (eih . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
-
- (feh . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (fes . ,(ly:make-pitch -1 3 FLAT))
- (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fis . ,(ly:make-pitch -1 3 SHARP))
- (fih . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
-
- (geh . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (ges . ,(ly:make-pitch -1 4 FLAT))
- (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gis . ,(ly:make-pitch -1 4 SHARP))
- (gih . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
-
- (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (aes . ,(ly:make-pitch -1 5 FLAT))
- (aeseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (as . ,(ly:make-pitch -1 5 FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (ais . ,(ly:make-pitch -1 5 SHARP))
- (aih . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (beses . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
-
- (beh . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (bes . ,(ly:make-pitch -1 6 FLAT))
- (beseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (b . ,(ly:make-pitch -1 6 NATURAL))
- (bis . ,(ly:make-pitch -1 6 SHARP))
- (bih . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (bisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (bisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (ces . ,(ly:make-pitch -1 0 FLAT))
+ (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (cis . ,(ly:make-pitch -1 0 SHARP))
+ (cih . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+
+ (deh . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (des . ,(ly:make-pitch -1 1 FLAT))
+ (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dis . ,(ly:make-pitch -1 1 SHARP))
+ (dih . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+
+ (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (ees . ,(ly:make-pitch -1 2 FLAT))
+ (eeseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (es . ,(ly:make-pitch -1 2 FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eis . ,(ly:make-pitch -1 2 SHARP))
+ (eih . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+
+ (feh . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (fes . ,(ly:make-pitch -1 3 FLAT))
+ (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fis . ,(ly:make-pitch -1 3 SHARP))
+ (fih . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+
+ (geh . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (ges . ,(ly:make-pitch -1 4 FLAT))
+ (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gis . ,(ly:make-pitch -1 4 SHARP))
+ (gih . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+
+ (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (aes . ,(ly:make-pitch -1 5 FLAT))
+ (aeseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (as . ,(ly:make-pitch -1 5 FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (ais . ,(ly:make-pitch -1 5 SHARP))
+ (aih . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (beses . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+
+ (beh . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (bes . ,(ly:make-pitch -1 6 FLAT))
+ (beseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (b . ,(ly:make-pitch -1 6 NATURAL))
+ (bis . ,(ly:make-pitch -1 6 SHARP))
+ (bih . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (bisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (bisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Catalan -----------------------------------------------;
;; Catalan: do re mi fa sol la si
(catalan . (
- (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (dob . ,(ly:make-pitch -1 0 FLAT))
- (do . ,(ly:make-pitch -1 0 NATURAL))
- (dod . ,(ly:make-pitch -1 0 SHARP))
- (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (reb . ,(ly:make-pitch -1 1 FLAT))
- (re . ,(ly:make-pitch -1 1 NATURAL))
- (red . ,(ly:make-pitch -1 1 SHARP))
- (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (mib . ,(ly:make-pitch -1 2 FLAT))
- (mi . ,(ly:make-pitch -1 2 NATURAL))
- (mid . ,(ly:make-pitch -1 2 SHARP))
- (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fab . ,(ly:make-pitch -1 3 FLAT))
- (fa . ,(ly:make-pitch -1 3 NATURAL))
- (fad . ,(ly:make-pitch -1 3 SHARP))
- (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (solb . ,(ly:make-pitch -1 4 FLAT))
- (sol . ,(ly:make-pitch -1 4 NATURAL))
- (sold . ,(ly:make-pitch -1 4 SHARP))
- (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (lab . ,(ly:make-pitch -1 5 FLAT))
- (la . ,(ly:make-pitch -1 5 NATURAL))
- (lad . ,(ly:make-pitch -1 5 SHARP))
- (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (sib . ,(ly:make-pitch -1 6 FLAT))
- (si . ,(ly:make-pitch -1 6 NATURAL))
- (sid . ,(ly:make-pitch -1 6 SHARP))
- (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
-
- ;; Now that we have espanol.ly, should these be junked? --jcn
- (dos . ,(ly:make-pitch -1 0 SHARP))
- (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (res . ,(ly:make-pitch -1 1 SHARP))
- (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (mis . ,(ly:make-pitch -1 2 SHARP))
- (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (fas . ,(ly:make-pitch -1 3 SHARP))
- (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (sols . ,(ly:make-pitch -1 4 SHARP))
- (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (las . ,(ly:make-pitch -1 5 SHARP))
- (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (sis . ,(ly:make-pitch -1 6 SHARP))
- (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (dob . ,(ly:make-pitch -1 0 FLAT))
+ (do . ,(ly:make-pitch -1 0 NATURAL))
+ (dod . ,(ly:make-pitch -1 0 SHARP))
+ (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (reb . ,(ly:make-pitch -1 1 FLAT))
+ (re . ,(ly:make-pitch -1 1 NATURAL))
+ (red . ,(ly:make-pitch -1 1 SHARP))
+ (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (mib . ,(ly:make-pitch -1 2 FLAT))
+ (mi . ,(ly:make-pitch -1 2 NATURAL))
+ (mid . ,(ly:make-pitch -1 2 SHARP))
+ (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fab . ,(ly:make-pitch -1 3 FLAT))
+ (fa . ,(ly:make-pitch -1 3 NATURAL))
+ (fad . ,(ly:make-pitch -1 3 SHARP))
+ (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (solb . ,(ly:make-pitch -1 4 FLAT))
+ (sol . ,(ly:make-pitch -1 4 NATURAL))
+ (sold . ,(ly:make-pitch -1 4 SHARP))
+ (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (lab . ,(ly:make-pitch -1 5 FLAT))
+ (la . ,(ly:make-pitch -1 5 NATURAL))
+ (lad . ,(ly:make-pitch -1 5 SHARP))
+ (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (sib . ,(ly:make-pitch -1 6 FLAT))
+ (si . ,(ly:make-pitch -1 6 NATURAL))
+ (sid . ,(ly:make-pitch -1 6 SHARP))
+ (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+
+ ;; Now that we have espanol.ly, should these be junked? --jcn
+ (dos . ,(ly:make-pitch -1 0 SHARP))
+ (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (res . ,(ly:make-pitch -1 1 SHARP))
+ (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (mis . ,(ly:make-pitch -1 2 SHARP))
+ (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (fas . ,(ly:make-pitch -1 3 SHARP))
+ (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (sols . ,(ly:make-pitch -1 4 SHARP))
+ (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (las . ,(ly:make-pitch -1 5 SHARP))
+ (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (sis . ,(ly:make-pitch -1 6 SHARP))
+ (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Deutsch -----------------------------------------------;
;; German: c d e f g a b h
(deutsch . (
- (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (ces . ,(ly:make-pitch -1 0 FLAT))
- (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (cih . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (cis . ,(ly:make-pitch -1 0 SHARP))
- (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (des . ,(ly:make-pitch -1 1 FLAT))
- (deh . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dih . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (dis . ,(ly:make-pitch -1 1 SHARP))
- (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (eseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (es . ,(ly:make-pitch -1 2 FLAT))
- (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eih . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (eis . ,(ly:make-pitch -1 2 SHARP))
- (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (fes . ,(ly:make-pitch -1 3 FLAT))
- (feh . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fih . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fis . ,(ly:make-pitch -1 3 SHARP))
- (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (ges . ,(ly:make-pitch -1 4 FLAT))
- (geh . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gih . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (gis . ,(ly:make-pitch -1 4 SHARP))
- (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (asah . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas
- (aseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (as . ,(ly:make-pitch -1 5 FLAT))
- (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (aih . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (ais . ,(ly:make-pitch -1 5 SHARP))
- (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (heseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (b . ,(ly:make-pitch -1 6 FLAT))
- (beh . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (h . ,(ly:make-pitch -1 6 NATURAL))
- (hih . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (his . ,(ly:make-pitch -1 6 SHARP))
- (hisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (ces . ,(ly:make-pitch -1 0 FLAT))
+ (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (cih . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (cis . ,(ly:make-pitch -1 0 SHARP))
+ (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (des . ,(ly:make-pitch -1 1 FLAT))
+ (deh . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dih . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (dis . ,(ly:make-pitch -1 1 SHARP))
+ (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (eseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (es . ,(ly:make-pitch -1 2 FLAT))
+ (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eih . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (eis . ,(ly:make-pitch -1 2 SHARP))
+ (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (fes . ,(ly:make-pitch -1 3 FLAT))
+ (feh . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fih . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fis . ,(ly:make-pitch -1 3 SHARP))
+ (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (ges . ,(ly:make-pitch -1 4 FLAT))
+ (geh . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gih . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (gis . ,(ly:make-pitch -1 4 SHARP))
+ (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (asah . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas
+ (aseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (as . ,(ly:make-pitch -1 5 FLAT))
+ (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (aih . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (ais . ,(ly:make-pitch -1 5 SHARP))
+ (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (heseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (b . ,(ly:make-pitch -1 6 FLAT))
+ (beh . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (h . ,(ly:make-pitch -1 6 NATURAL))
+ (hih . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (his . ,(ly:make-pitch -1 6 SHARP))
+ (hisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: English -----------------------------------------------;
;; tqs = three-quarter[-tones] sharp
(english . (
- (cflatflat . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (cflat . ,(ly:make-pitch -1 0 FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (csharp . ,(ly:make-pitch -1 0 SHARP))
- (csharpsharp . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (dflatflat . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (dflat . ,(ly:make-pitch -1 1 FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dsharp . ,(ly:make-pitch -1 1 SHARP))
- (dsharpsharp . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (eflatflat . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (eflat . ,(ly:make-pitch -1 2 FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (esharp . ,(ly:make-pitch -1 2 SHARP))
- (esharpsharp . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (fflatflat . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fflat . ,(ly:make-pitch -1 3 FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fsharp . ,(ly:make-pitch -1 3 SHARP))
- (fsharpsharp . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (gflatflat . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (gflat . ,(ly:make-pitch -1 4 FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gsharp . ,(ly:make-pitch -1 4 SHARP))
- (gsharpsharp . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (aflatflat . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (aflat . ,(ly:make-pitch -1 5 FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (asharp . ,(ly:make-pitch -1 5 SHARP))
- (asharpsharp . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (bflatflat . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (bflat . ,(ly:make-pitch -1 6 FLAT))
- (b . ,(ly:make-pitch -1 6 NATURAL))
- (bsharp . ,(ly:make-pitch -1 6 SHARP))
- (bsharpsharp . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
-
- (cff . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (ctqf . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (cf . ,(ly:make-pitch -1 0 FLAT))
- (cqf . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (cqs . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (cs . ,(ly:make-pitch -1 0 SHARP))
- (ctqs . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (css . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (cx . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (dff . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (dtqf . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (df . ,(ly:make-pitch -1 1 FLAT))
- (dqf . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dqs . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (ds . ,(ly:make-pitch -1 1 SHARP))
- (dtqs . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (dss . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (dx . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (eff . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (etqf . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (ef . ,(ly:make-pitch -1 2 FLAT))
- (eqf . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eqs . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (es . ,(ly:make-pitch -1 2 SHARP))
- (etqs . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (ess . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (ex . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (fff . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (ftqf . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (ff . ,(ly:make-pitch -1 3 FLAT))
- (fqf . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fqs . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fs . ,(ly:make-pitch -1 3 SHARP))
- (ftqs . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fss . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (fx . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (gff . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (gtqf . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (gf . ,(ly:make-pitch -1 4 FLAT))
- (gqf . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gqs . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (gs . ,(ly:make-pitch -1 4 SHARP))
- (gtqs . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (gss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (gx . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (aff . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (atqf . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (af . ,(ly:make-pitch -1 5 FLAT))
- (aqf . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (aqs . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (as . ,(ly:make-pitch -1 5 SHARP))
- (atqs . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (ass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (ax . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (bff . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (btqf . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (bf . ,(ly:make-pitch -1 6 FLAT))
- (bqf . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (b . ,(ly:make-pitch -1 6 NATURAL))
- (bqs . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (bs . ,(ly:make-pitch -1 6 SHARP))
- (btqs . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (bss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- (bx . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (cflatflat . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (cflat . ,(ly:make-pitch -1 0 FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (csharp . ,(ly:make-pitch -1 0 SHARP))
+ (csharpsharp . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (dflatflat . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (dflat . ,(ly:make-pitch -1 1 FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dsharp . ,(ly:make-pitch -1 1 SHARP))
+ (dsharpsharp . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (eflatflat . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (eflat . ,(ly:make-pitch -1 2 FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (esharp . ,(ly:make-pitch -1 2 SHARP))
+ (esharpsharp . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (fflatflat . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fflat . ,(ly:make-pitch -1 3 FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fsharp . ,(ly:make-pitch -1 3 SHARP))
+ (fsharpsharp . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (gflatflat . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (gflat . ,(ly:make-pitch -1 4 FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gsharp . ,(ly:make-pitch -1 4 SHARP))
+ (gsharpsharp . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (aflatflat . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (aflat . ,(ly:make-pitch -1 5 FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (asharp . ,(ly:make-pitch -1 5 SHARP))
+ (asharpsharp . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (bflatflat . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (bflat . ,(ly:make-pitch -1 6 FLAT))
+ (b . ,(ly:make-pitch -1 6 NATURAL))
+ (bsharp . ,(ly:make-pitch -1 6 SHARP))
+ (bsharpsharp . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+
+ (cff . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (ctqf . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (cf . ,(ly:make-pitch -1 0 FLAT))
+ (cqf . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (cqs . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (cs . ,(ly:make-pitch -1 0 SHARP))
+ (ctqs . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (css . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (cx . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (dff . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (dtqf . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (df . ,(ly:make-pitch -1 1 FLAT))
+ (dqf . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dqs . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (ds . ,(ly:make-pitch -1 1 SHARP))
+ (dtqs . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (dss . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (dx . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (eff . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (etqf . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (ef . ,(ly:make-pitch -1 2 FLAT))
+ (eqf . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eqs . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (es . ,(ly:make-pitch -1 2 SHARP))
+ (etqs . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (ess . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (ex . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (fff . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (ftqf . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (ff . ,(ly:make-pitch -1 3 FLAT))
+ (fqf . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fqs . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fs . ,(ly:make-pitch -1 3 SHARP))
+ (ftqs . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fss . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (fx . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (gff . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (gtqf . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (gf . ,(ly:make-pitch -1 4 FLAT))
+ (gqf . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gqs . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (gs . ,(ly:make-pitch -1 4 SHARP))
+ (gtqs . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (gss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (gx . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (aff . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (atqf . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (af . ,(ly:make-pitch -1 5 FLAT))
+ (aqf . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (aqs . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (as . ,(ly:make-pitch -1 5 SHARP))
+ (atqs . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (ass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (ax . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (bff . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (btqf . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (bf . ,(ly:make-pitch -1 6 FLAT))
+ (bqf . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (b . ,(ly:make-pitch -1 6 NATURAL))
+ (bqs . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (bs . ,(ly:make-pitch -1 6 SHARP))
+ (btqs . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (bss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ (bx . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Espanol -----------------------------------------------;
;; Spanish: do re mi fa sol la si
(espanol . (
- (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (dotcb . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (dob . ,(ly:make-pitch -1 0 FLAT))
- (docb . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (do . ,(ly:make-pitch -1 0 NATURAL))
- (docs . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (dos . ,(ly:make-pitch -1 0 SHARP))
- (dotcs . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (dox . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (retcb . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (reb . ,(ly:make-pitch -1 1 FLAT))
- (recb . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (re . ,(ly:make-pitch -1 1 NATURAL))
- (recs . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (res . ,(ly:make-pitch -1 1 SHARP))
- (retcs . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (rex . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (mitcb . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (mib . ,(ly:make-pitch -1 2 FLAT))
- (micb . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (mi . ,(ly:make-pitch -1 2 NATURAL))
- (mics . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (mis . ,(ly:make-pitch -1 2 SHARP))
- (mitcs . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (mix . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fatcb . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (fab . ,(ly:make-pitch -1 3 FLAT))
- (facb . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (fa . ,(ly:make-pitch -1 3 NATURAL))
- (facs . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fas . ,(ly:make-pitch -1 3 SHARP))
- (fatcs . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (fax . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (soltcb . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (solb . ,(ly:make-pitch -1 4 FLAT))
- (solcb . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (sol . ,(ly:make-pitch -1 4 NATURAL))
- (solcs . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (sols . ,(ly:make-pitch -1 4 SHARP))
- (soltcs . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (solx . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (latcb . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (lab . ,(ly:make-pitch -1 5 FLAT))
- (lacb . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (la . ,(ly:make-pitch -1 5 NATURAL))
- (lacs . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (las . ,(ly:make-pitch -1 5 SHARP))
- (latcs . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (lax . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (sitcb . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (sib . ,(ly:make-pitch -1 6 FLAT))
- (sicb . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (si . ,(ly:make-pitch -1 6 NATURAL))
- (sics . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (sis . ,(ly:make-pitch -1 6 SHARP))
- (sitcs . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- (six . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (dotcb . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (dob . ,(ly:make-pitch -1 0 FLAT))
+ (docb . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (do . ,(ly:make-pitch -1 0 NATURAL))
+ (docs . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (dos . ,(ly:make-pitch -1 0 SHARP))
+ (dotcs . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (dox . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (retcb . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (reb . ,(ly:make-pitch -1 1 FLAT))
+ (recb . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (re . ,(ly:make-pitch -1 1 NATURAL))
+ (recs . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (res . ,(ly:make-pitch -1 1 SHARP))
+ (retcs . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (rex . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (mitcb . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (mib . ,(ly:make-pitch -1 2 FLAT))
+ (micb . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (mi . ,(ly:make-pitch -1 2 NATURAL))
+ (mics . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (mis . ,(ly:make-pitch -1 2 SHARP))
+ (mitcs . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (mix . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fatcb . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (fab . ,(ly:make-pitch -1 3 FLAT))
+ (facb . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (fa . ,(ly:make-pitch -1 3 NATURAL))
+ (facs . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fas . ,(ly:make-pitch -1 3 SHARP))
+ (fatcs . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (fax . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (soltcb . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (solb . ,(ly:make-pitch -1 4 FLAT))
+ (solcb . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (sol . ,(ly:make-pitch -1 4 NATURAL))
+ (solcs . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (sols . ,(ly:make-pitch -1 4 SHARP))
+ (soltcs . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (solx . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (latcb . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (lab . ,(ly:make-pitch -1 5 FLAT))
+ (lacb . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (la . ,(ly:make-pitch -1 5 NATURAL))
+ (lacs . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (las . ,(ly:make-pitch -1 5 SHARP))
+ (latcs . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (lax . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (sitcb . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (sib . ,(ly:make-pitch -1 6 FLAT))
+ (sicb . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (si . ,(ly:make-pitch -1 6 NATURAL))
+ (sics . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (sis . ,(ly:make-pitch -1 6 SHARP))
+ (sitcs . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ (six . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Italiano ----------------------------------------------;
;; Italian: do re mi fa sol la si
(italiano . (
- (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (dobsb . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (dob . ,(ly:make-pitch -1 0 FLAT))
- (dosb . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (do . ,(ly:make-pitch -1 0 NATURAL))
- (dosd . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (dod . ,(ly:make-pitch -1 0 SHARP))
- (dodsd . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (rebsb . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (reb . ,(ly:make-pitch -1 1 FLAT))
- (resb . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (re . ,(ly:make-pitch -1 1 NATURAL))
- (resd . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (red . ,(ly:make-pitch -1 1 SHARP))
- (redsd . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (mibsb . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (mib . ,(ly:make-pitch -1 2 FLAT))
- (misb . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (mi . ,(ly:make-pitch -1 2 NATURAL))
- (misd . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (mid . ,(ly:make-pitch -1 2 SHARP))
- (midsd . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fabsb . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (fab . ,(ly:make-pitch -1 3 FLAT))
- (fasb . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (fa . ,(ly:make-pitch -1 3 NATURAL))
- (fasd . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fad . ,(ly:make-pitch -1 3 SHARP))
- (fadsd . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (solbsb . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (solb . ,(ly:make-pitch -1 4 FLAT))
- (solsb . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (sol . ,(ly:make-pitch -1 4 NATURAL))
- (solsd . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (sold . ,(ly:make-pitch -1 4 SHARP))
- (soldsd . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (labsb . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (lab . ,(ly:make-pitch -1 5 FLAT))
- (lasb . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (la . ,(ly:make-pitch -1 5 NATURAL))
- (lasd . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (lad . ,(ly:make-pitch -1 5 SHARP))
- (ladsd . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (sibsb . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (sib . ,(ly:make-pitch -1 6 FLAT))
- (sisb . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (si . ,(ly:make-pitch -1 6 NATURAL))
- (sisd . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (sid . ,(ly:make-pitch -1 6 SHARP))
- (sidsd . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
-
- ))
+ (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (dobsb . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (dob . ,(ly:make-pitch -1 0 FLAT))
+ (dosb . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (do . ,(ly:make-pitch -1 0 NATURAL))
+ (dosd . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (dod . ,(ly:make-pitch -1 0 SHARP))
+ (dodsd . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (rebsb . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (reb . ,(ly:make-pitch -1 1 FLAT))
+ (resb . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (re . ,(ly:make-pitch -1 1 NATURAL))
+ (resd . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (red . ,(ly:make-pitch -1 1 SHARP))
+ (redsd . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (mibsb . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (mib . ,(ly:make-pitch -1 2 FLAT))
+ (misb . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (mi . ,(ly:make-pitch -1 2 NATURAL))
+ (misd . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (mid . ,(ly:make-pitch -1 2 SHARP))
+ (midsd . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fabsb . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (fab . ,(ly:make-pitch -1 3 FLAT))
+ (fasb . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (fa . ,(ly:make-pitch -1 3 NATURAL))
+ (fasd . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fad . ,(ly:make-pitch -1 3 SHARP))
+ (fadsd . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (solbsb . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (solb . ,(ly:make-pitch -1 4 FLAT))
+ (solsb . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (sol . ,(ly:make-pitch -1 4 NATURAL))
+ (solsd . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (sold . ,(ly:make-pitch -1 4 SHARP))
+ (soldsd . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (labsb . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (lab . ,(ly:make-pitch -1 5 FLAT))
+ (lasb . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (la . ,(ly:make-pitch -1 5 NATURAL))
+ (lasd . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (lad . ,(ly:make-pitch -1 5 SHARP))
+ (ladsd . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (sibsb . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (sib . ,(ly:make-pitch -1 6 FLAT))
+ (sisb . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (si . ,(ly:make-pitch -1 6 NATURAL))
+ (sisd . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (sid . ,(ly:make-pitch -1 6 SHARP))
+ (sidsd . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+
+ ))
;; Language: Norsk -------------------------------------------------;
;; Norwegian: c d e f g a b h
(norsk . (
- (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (ces . ,(ly:make-pitch -1 0 FLAT))
- (cess . ,(ly:make-pitch -1 0 FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (cis . ,(ly:make-pitch -1 0 SHARP))
- (ciss . ,(ly:make-pitch -1 0 SHARP))
- (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (des . ,(ly:make-pitch -1 1 FLAT))
- (dess . ,(ly:make-pitch -1 1 FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dis . ,(ly:make-pitch -1 1 SHARP))
- (diss . ,(ly:make-pitch -1 1 SHARP))
- (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (eessess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (ees . ,(ly:make-pitch -1 2 FLAT))
- (eess . ,(ly:make-pitch -1 2 FLAT))
- (es . ,(ly:make-pitch -1 2 FLAT))
- (ess . ,(ly:make-pitch -1 2 FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eis . ,(ly:make-pitch -1 2 SHARP))
- (eiss . ,(ly:make-pitch -1 2 SHARP))
- (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fes . ,(ly:make-pitch -1 3 FLAT))
- (fess . ,(ly:make-pitch -1 3 FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fis . ,(ly:make-pitch -1 3 SHARP))
- (fiss . ,(ly:make-pitch -1 3 SHARP))
- (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (ges . ,(ly:make-pitch -1 4 FLAT))
- (gess . ,(ly:make-pitch -1 4 FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gis . ,(ly:make-pitch -1 4 SHARP))
- (giss . ,(ly:make-pitch -1 4 SHARP))
- (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (aessess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (aes . ,(ly:make-pitch -1 5 FLAT))
- (aess . ,(ly:make-pitch -1 5 FLAT))
- (as . ,(ly:make-pitch -1 5 FLAT))
- (ass . ,(ly:make-pitch -1 5 FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (ais . ,(ly:make-pitch -1 5 SHARP))
- (aiss . ,(ly:make-pitch -1 5 SHARP))
- (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (bess . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (b . ,(ly:make-pitch -1 6 FLAT))
- (b . ,(ly:make-pitch -1 6 FLAT))
- (h . ,(ly:make-pitch -1 6 NATURAL))
- (his . ,(ly:make-pitch -1 6 SHARP))
- (hiss . ,(ly:make-pitch -1 6 SHARP))
- (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (ces . ,(ly:make-pitch -1 0 FLAT))
+ (cess . ,(ly:make-pitch -1 0 FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (cis . ,(ly:make-pitch -1 0 SHARP))
+ (ciss . ,(ly:make-pitch -1 0 SHARP))
+ (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (des . ,(ly:make-pitch -1 1 FLAT))
+ (dess . ,(ly:make-pitch -1 1 FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dis . ,(ly:make-pitch -1 1 SHARP))
+ (diss . ,(ly:make-pitch -1 1 SHARP))
+ (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (eessess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (ees . ,(ly:make-pitch -1 2 FLAT))
+ (eess . ,(ly:make-pitch -1 2 FLAT))
+ (es . ,(ly:make-pitch -1 2 FLAT))
+ (ess . ,(ly:make-pitch -1 2 FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eis . ,(ly:make-pitch -1 2 SHARP))
+ (eiss . ,(ly:make-pitch -1 2 SHARP))
+ (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fes . ,(ly:make-pitch -1 3 FLAT))
+ (fess . ,(ly:make-pitch -1 3 FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fis . ,(ly:make-pitch -1 3 SHARP))
+ (fiss . ,(ly:make-pitch -1 3 SHARP))
+ (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (ges . ,(ly:make-pitch -1 4 FLAT))
+ (gess . ,(ly:make-pitch -1 4 FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gis . ,(ly:make-pitch -1 4 SHARP))
+ (giss . ,(ly:make-pitch -1 4 SHARP))
+ (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (aessess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (aes . ,(ly:make-pitch -1 5 FLAT))
+ (aess . ,(ly:make-pitch -1 5 FLAT))
+ (as . ,(ly:make-pitch -1 5 FLAT))
+ (ass . ,(ly:make-pitch -1 5 FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (ais . ,(ly:make-pitch -1 5 SHARP))
+ (aiss . ,(ly:make-pitch -1 5 SHARP))
+ (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (bess . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (b . ,(ly:make-pitch -1 6 FLAT))
+ (b . ,(ly:make-pitch -1 6 FLAT))
+ (h . ,(ly:make-pitch -1 6 NATURAL))
+ (his . ,(ly:make-pitch -1 6 SHARP))
+ (hiss . ,(ly:make-pitch -1 6 SHARP))
+ (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Portugues ---------------------------------------------;
;; Portuguese: do re mi fa sol la si
(portugues . (
- (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (dobtqt . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
- (dob . ,(ly:make-pitch -1 0 FLAT))
- (dobqt . ,(ly:make-pitch -1 0 SEMI-FLAT))
- (do . ,(ly:make-pitch -1 0 NATURAL))
- (dosqt . ,(ly:make-pitch -1 0 SEMI-SHARP))
- (dos . ,(ly:make-pitch -1 0 SHARP))
- (dostqt . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
- (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (rebtqt . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
- (reb . ,(ly:make-pitch -1 1 FLAT))
- (rebqt . ,(ly:make-pitch -1 1 SEMI-FLAT))
- (re . ,(ly:make-pitch -1 1 NATURAL))
- (resqt . ,(ly:make-pitch -1 1 SEMI-SHARP))
- (res . ,(ly:make-pitch -1 1 SHARP))
- (restqt . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
- (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (mibtqt . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
- (mib . ,(ly:make-pitch -1 2 FLAT))
- (mibqt . ,(ly:make-pitch -1 2 SEMI-FLAT))
- (mi . ,(ly:make-pitch -1 2 NATURAL))
- (misqt . ,(ly:make-pitch -1 2 SEMI-SHARP))
- (mis . ,(ly:make-pitch -1 2 SHARP))
- (mistqt . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
- (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fabtqt . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
- (fab . ,(ly:make-pitch -1 3 FLAT))
- (fabqt . ,(ly:make-pitch -1 3 SEMI-FLAT))
- (fa . ,(ly:make-pitch -1 3 NATURAL))
- (fasqt . ,(ly:make-pitch -1 3 SEMI-SHARP))
- (fas . ,(ly:make-pitch -1 3 SHARP))
- (fastqt . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
- (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (solbtqt . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
- (solb . ,(ly:make-pitch -1 4 FLAT))
- (solbqt . ,(ly:make-pitch -1 4 SEMI-FLAT))
- (sol . ,(ly:make-pitch -1 4 NATURAL))
- (solsqt . ,(ly:make-pitch -1 4 SEMI-SHARP))
- (sols . ,(ly:make-pitch -1 4 SHARP))
- (solstqt . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
- (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (labtqt . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
- (lab . ,(ly:make-pitch -1 5 FLAT))
- (labqt . ,(ly:make-pitch -1 5 SEMI-FLAT))
- (la . ,(ly:make-pitch -1 5 NATURAL))
- (lasqt . ,(ly:make-pitch -1 5 SEMI-SHARP))
- (las . ,(ly:make-pitch -1 5 SHARP))
- (lastqt . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
- (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (sibtqt . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
- (sib . ,(ly:make-pitch -1 6 FLAT))
- (sibqt . ,(ly:make-pitch -1 6 SEMI-FLAT))
- (si . ,(ly:make-pitch -1 6 NATURAL))
- (sisqt . ,(ly:make-pitch -1 6 SEMI-SHARP))
- (sis . ,(ly:make-pitch -1 6 SHARP))
- (sistqt . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
- (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
-
- ))
+ (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (dobtqt . ,(ly:make-pitch -1 0 THREE-Q-FLAT))
+ (dob . ,(ly:make-pitch -1 0 FLAT))
+ (dobqt . ,(ly:make-pitch -1 0 SEMI-FLAT))
+ (do . ,(ly:make-pitch -1 0 NATURAL))
+ (dosqt . ,(ly:make-pitch -1 0 SEMI-SHARP))
+ (dos . ,(ly:make-pitch -1 0 SHARP))
+ (dostqt . ,(ly:make-pitch -1 0 THREE-Q-SHARP))
+ (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (rebtqt . ,(ly:make-pitch -1 1 THREE-Q-FLAT))
+ (reb . ,(ly:make-pitch -1 1 FLAT))
+ (rebqt . ,(ly:make-pitch -1 1 SEMI-FLAT))
+ (re . ,(ly:make-pitch -1 1 NATURAL))
+ (resqt . ,(ly:make-pitch -1 1 SEMI-SHARP))
+ (res . ,(ly:make-pitch -1 1 SHARP))
+ (restqt . ,(ly:make-pitch -1 1 THREE-Q-SHARP))
+ (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (mibtqt . ,(ly:make-pitch -1 2 THREE-Q-FLAT))
+ (mib . ,(ly:make-pitch -1 2 FLAT))
+ (mibqt . ,(ly:make-pitch -1 2 SEMI-FLAT))
+ (mi . ,(ly:make-pitch -1 2 NATURAL))
+ (misqt . ,(ly:make-pitch -1 2 SEMI-SHARP))
+ (mis . ,(ly:make-pitch -1 2 SHARP))
+ (mistqt . ,(ly:make-pitch -1 2 THREE-Q-SHARP))
+ (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fabtqt . ,(ly:make-pitch -1 3 THREE-Q-FLAT))
+ (fab . ,(ly:make-pitch -1 3 FLAT))
+ (fabqt . ,(ly:make-pitch -1 3 SEMI-FLAT))
+ (fa . ,(ly:make-pitch -1 3 NATURAL))
+ (fasqt . ,(ly:make-pitch -1 3 SEMI-SHARP))
+ (fas . ,(ly:make-pitch -1 3 SHARP))
+ (fastqt . ,(ly:make-pitch -1 3 THREE-Q-SHARP))
+ (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (solbtqt . ,(ly:make-pitch -1 4 THREE-Q-FLAT))
+ (solb . ,(ly:make-pitch -1 4 FLAT))
+ (solbqt . ,(ly:make-pitch -1 4 SEMI-FLAT))
+ (sol . ,(ly:make-pitch -1 4 NATURAL))
+ (solsqt . ,(ly:make-pitch -1 4 SEMI-SHARP))
+ (sols . ,(ly:make-pitch -1 4 SHARP))
+ (solstqt . ,(ly:make-pitch -1 4 THREE-Q-SHARP))
+ (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (labtqt . ,(ly:make-pitch -1 5 THREE-Q-FLAT))
+ (lab . ,(ly:make-pitch -1 5 FLAT))
+ (labqt . ,(ly:make-pitch -1 5 SEMI-FLAT))
+ (la . ,(ly:make-pitch -1 5 NATURAL))
+ (lasqt . ,(ly:make-pitch -1 5 SEMI-SHARP))
+ (las . ,(ly:make-pitch -1 5 SHARP))
+ (lastqt . ,(ly:make-pitch -1 5 THREE-Q-SHARP))
+ (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (sibtqt . ,(ly:make-pitch -1 6 THREE-Q-FLAT))
+ (sib . ,(ly:make-pitch -1 6 FLAT))
+ (sibqt . ,(ly:make-pitch -1 6 SEMI-FLAT))
+ (si . ,(ly:make-pitch -1 6 NATURAL))
+ (sisqt . ,(ly:make-pitch -1 6 SEMI-SHARP))
+ (sis . ,(ly:make-pitch -1 6 SHARP))
+ (sistqt . ,(ly:make-pitch -1 6 THREE-Q-SHARP))
+ (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+
+ ))
;; Language: Suomi -------------------------------------------------;
;; Finnish: c d e f g a b h
(suomi . (
- (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (ces . ,(ly:make-pitch -1 0 FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (cis . ,(ly:make-pitch -1 0 SHARP))
- (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (des . ,(ly:make-pitch -1 1 FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (dis . ,(ly:make-pitch -1 1 SHARP))
- (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (es . ,(ly:make-pitch -1 2 FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eis . ,(ly:make-pitch -1 2 SHARP))
- (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fes . ,(ly:make-pitch -1 3 FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fis . ,(ly:make-pitch -1 3 SHARP))
- (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (ges . ,(ly:make-pitch -1 4 FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (gis . ,(ly:make-pitch -1 4 SHARP))
- (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas
- (as . ,(ly:make-pitch -1 5 FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (ais . ,(ly:make-pitch -1 5 SHARP))
- (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (bb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;; should be bes. Kept for downwards compatibility
- (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;;non-standard name for bb
- (b . ,(ly:make-pitch -1 6 FLAT))
- (h . ,(ly:make-pitch -1 6 NATURAL))
- (his . ,(ly:make-pitch -1 6 SHARP))
- (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (ces . ,(ly:make-pitch -1 0 FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (cis . ,(ly:make-pitch -1 0 SHARP))
+ (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (des . ,(ly:make-pitch -1 1 FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (dis . ,(ly:make-pitch -1 1 SHARP))
+ (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (es . ,(ly:make-pitch -1 2 FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eis . ,(ly:make-pitch -1 2 SHARP))
+ (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fes . ,(ly:make-pitch -1 3 FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fis . ,(ly:make-pitch -1 3 SHARP))
+ (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (ges . ,(ly:make-pitch -1 4 FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (gis . ,(ly:make-pitch -1 4 SHARP))
+ (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas
+ (as . ,(ly:make-pitch -1 5 FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (ais . ,(ly:make-pitch -1 5 SHARP))
+ (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (bb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;; should be bes. Kept for downwards compatibility
+ (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;;non-standard name for bb
+ (b . ,(ly:make-pitch -1 6 FLAT))
+ (h . ,(ly:make-pitch -1 6 NATURAL))
+ (his . ,(ly:make-pitch -1 6 SHARP))
+ (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Svenska -----------------------------------------------;
;; Swedish: c d e f g a b h
(svenska . (
- (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (cess . ,(ly:make-pitch -1 0 FLAT))
- (c . ,(ly:make-pitch -1 0 NATURAL))
- (ciss . ,(ly:make-pitch -1 0 SHARP))
- (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
- (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (dess . ,(ly:make-pitch -1 1 FLAT))
- (d . ,(ly:make-pitch -1 1 NATURAL))
- (diss . ,(ly:make-pitch -1 1 SHARP))
- (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
- (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (ess . ,(ly:make-pitch -1 2 FLAT))
- (e . ,(ly:make-pitch -1 2 NATURAL))
- (eiss . ,(ly:make-pitch -1 2 SHARP))
- (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
- (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fess . ,(ly:make-pitch -1 3 FLAT))
- (f . ,(ly:make-pitch -1 3 NATURAL))
- (fiss . ,(ly:make-pitch -1 3 SHARP))
- (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
- (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (gess . ,(ly:make-pitch -1 4 FLAT))
- (g . ,(ly:make-pitch -1 4 NATURAL))
- (giss . ,(ly:make-pitch -1 4 SHARP))
- (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
- (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (ass . ,(ly:make-pitch -1 5 FLAT))
- (a . ,(ly:make-pitch -1 5 NATURAL))
- (aiss . ,(ly:make-pitch -1 5 SHARP))
- (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
- (hessess . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (b . ,(ly:make-pitch -1 6 FLAT))
- (h . ,(ly:make-pitch -1 6 NATURAL))
- (hiss . ,(ly:make-pitch -1 6 SHARP))
- (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (cess . ,(ly:make-pitch -1 0 FLAT))
+ (c . ,(ly:make-pitch -1 0 NATURAL))
+ (ciss . ,(ly:make-pitch -1 0 SHARP))
+ (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+ (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (dess . ,(ly:make-pitch -1 1 FLAT))
+ (d . ,(ly:make-pitch -1 1 NATURAL))
+ (diss . ,(ly:make-pitch -1 1 SHARP))
+ (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+ (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (ess . ,(ly:make-pitch -1 2 FLAT))
+ (e . ,(ly:make-pitch -1 2 NATURAL))
+ (eiss . ,(ly:make-pitch -1 2 SHARP))
+ (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+ (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fess . ,(ly:make-pitch -1 3 FLAT))
+ (f . ,(ly:make-pitch -1 3 NATURAL))
+ (fiss . ,(ly:make-pitch -1 3 SHARP))
+ (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+ (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (gess . ,(ly:make-pitch -1 4 FLAT))
+ (g . ,(ly:make-pitch -1 4 NATURAL))
+ (giss . ,(ly:make-pitch -1 4 SHARP))
+ (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+ (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (ass . ,(ly:make-pitch -1 5 FLAT))
+ (a . ,(ly:make-pitch -1 5 NATURAL))
+ (aiss . ,(ly:make-pitch -1 5 SHARP))
+ (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+ (hessess . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (b . ,(ly:make-pitch -1 6 FLAT))
+ (h . ,(ly:make-pitch -1 6 NATURAL))
+ (hiss . ,(ly:make-pitch -1 6 SHARP))
+ (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
;; Language: Vlaams ------------------------------------------------;
;; Flemish: do re mi fa sol la si
(vlaams . (
- (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
- (dob . ,(ly:make-pitch -1 0 FLAT))
- (do . ,(ly:make-pitch -1 0 NATURAL))
- (dok . ,(ly:make-pitch -1 0 SHARP))
- (dokk . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
-
- (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
- (reb . ,(ly:make-pitch -1 1 FLAT))
- (re . ,(ly:make-pitch -1 1 NATURAL))
- (rek . ,(ly:make-pitch -1 1 SHARP))
- (rekk . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
-
- (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
- (mib . ,(ly:make-pitch -1 2 FLAT))
- (mi . ,(ly:make-pitch -1 2 NATURAL))
- (mik . ,(ly:make-pitch -1 2 SHARP))
- (mikk . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
-
- (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
- (fab . ,(ly:make-pitch -1 3 FLAT))
- (fa . ,(ly:make-pitch -1 3 NATURAL))
- (fak . ,(ly:make-pitch -1 3 SHARP))
- (fakk . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
-
- (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
- (solb . ,(ly:make-pitch -1 4 FLAT))
- (sol . ,(ly:make-pitch -1 4 NATURAL))
- (solk . ,(ly:make-pitch -1 4 SHARP))
- (solkk . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
-
- (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
- (lab . ,(ly:make-pitch -1 5 FLAT))
- (la . ,(ly:make-pitch -1 5 NATURAL))
- (lak . ,(ly:make-pitch -1 5 SHARP))
- (lakk . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
-
- (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
- (sib . ,(ly:make-pitch -1 6 FLAT))
- (si . ,(ly:make-pitch -1 6 NATURAL))
- (sik . ,(ly:make-pitch -1 6 SHARP))
- (sikk . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
- ))
+ (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT))
+ (dob . ,(ly:make-pitch -1 0 FLAT))
+ (do . ,(ly:make-pitch -1 0 NATURAL))
+ (dok . ,(ly:make-pitch -1 0 SHARP))
+ (dokk . ,(ly:make-pitch -1 0 DOUBLE-SHARP))
+
+ (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT))
+ (reb . ,(ly:make-pitch -1 1 FLAT))
+ (re . ,(ly:make-pitch -1 1 NATURAL))
+ (rek . ,(ly:make-pitch -1 1 SHARP))
+ (rekk . ,(ly:make-pitch -1 1 DOUBLE-SHARP))
+
+ (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT))
+ (mib . ,(ly:make-pitch -1 2 FLAT))
+ (mi . ,(ly:make-pitch -1 2 NATURAL))
+ (mik . ,(ly:make-pitch -1 2 SHARP))
+ (mikk . ,(ly:make-pitch -1 2 DOUBLE-SHARP))
+
+ (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT))
+ (fab . ,(ly:make-pitch -1 3 FLAT))
+ (fa . ,(ly:make-pitch -1 3 NATURAL))
+ (fak . ,(ly:make-pitch -1 3 SHARP))
+ (fakk . ,(ly:make-pitch -1 3 DOUBLE-SHARP))
+
+ (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT))
+ (solb . ,(ly:make-pitch -1 4 FLAT))
+ (sol . ,(ly:make-pitch -1 4 NATURAL))
+ (solk . ,(ly:make-pitch -1 4 SHARP))
+ (solkk . ,(ly:make-pitch -1 4 DOUBLE-SHARP))
+
+ (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT))
+ (lab . ,(ly:make-pitch -1 5 FLAT))
+ (la . ,(ly:make-pitch -1 5 NATURAL))
+ (lak . ,(ly:make-pitch -1 5 SHARP))
+ (lakk . ,(ly:make-pitch -1 5 DOUBLE-SHARP))
+
+ (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT))
+ (sib . ,(ly:make-pitch -1 6 FLAT))
+ (si . ,(ly:make-pitch -1 6 NATURAL))
+ (sik . ,(ly:make-pitch -1 6 SHARP))
+ (sikk . ,(ly:make-pitch -1 6 DOUBLE-SHARP))
+ ))
))
;; add two native utf-8 aliases. Pairs obey cp-like order: '(old new)
(define-public (note-names-language parser str)
(_ "Select note names language.")
(let ((alist (assoc-get (string->symbol str)
- language-pitch-names
- '())))
+ language-pitch-names
+ '())))
(if (pair? alist)
- (begin
- (ly:debug (_ "Using `~a' note names...") str)
- (set! pitchnames alist)
- (ly:parser-set-note-names parser alist))
- (ly:warning (_ "Could not find language `~a'. Ignoring.") str))))
+ (begin
+ (ly:debug (_ "Using `~a' note names...") str)
+ (set! pitchnames alist)
+ (ly:parser-set-note-names parser alist))
+ (ly:warning (_ "Could not find language `~a'. Ignoring.") str))))
))
(map ly:register-stencil-expression
- (append (ly:all-stencil-commands)
- (ly:all-output-backend-commands)))
+ (append (ly:all-stencil-commands)
+ (ly:all-output-backend-commands)))
Example: Executing @samp{(function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
returns @samp{1/3}."
(if (null? function-list)
- arg
- (function-chain
- (apply (caar function-list) (append `(,arg) (cdar function-list)))
- (cdr 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.
@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))))))
+ 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)
@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)))
+ ((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."
;; 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)))
+ ((= 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)))
+ ((< 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?)
;; 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))))
+ (append `(,(or (< fill 3) (is-square? fill avals)))
+ (map (lambda (x) (= 0 (remainder fill x))) avals))))
;; Color a stencil gray
(define (gray-colorize stencil)
(define (rich-path-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-path-stencil
- ls
- thick
- (* x-stretch radius)
- (* y-stretch radius)
- #f
- (if gray? #t fill-translate))))
- (if (not gray?)
- empty-stencil
- ((rich-path-stencil ls x-stretch y-stretch proc)
- radius
- thick
- 1
- layout
- props))))))
+ ((fill-translate (key-fill-translate fill))
+ (gray? (eqv? fill-translate 0.5)))
+ (ly:stencil-add
+ ((if gray? gray-colorize identity)
+ (proc
+ (make-connected-path-stencil
+ ls
+ thick
+ (* x-stretch radius)
+ (* y-stretch radius)
+ #f
+ (if gray? #t fill-translate))))
+ (if (not gray?)
+ empty-stencil
+ ((rich-path-stencil ls x-stretch y-stretch proc)
+ radius
+ thick
+ 1
+ layout
+ props))))))
;; A connected path stencil without a surrounding proc
(define (standard-path-stencil ls x-stretch y-stretch)
(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))))))
+ ((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
+ ((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))))))
+ (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)
(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)))))
+ (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))))))))
+ `((,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
(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))))
+ (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))
+ (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)))
+ (markup
+ #:conditional-circle-markup
+ x
+ (markup #:abs-fontsize font-size #:number y))
+ (markup #:null)))
input-list
key-list))
(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)))))))
+ 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
+ layout
+ props
+ (make-general-align-markup
+ Y
+ CENTER
(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)))))))))
+ 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
(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))
+ (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)))
+ (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 (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))))
+ 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))
+ (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))
+ (lambda (x) (if (pair? x) x eos))
+ (assoc-keys alist)
+ alist))
;;; General drawing commands
;; 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-path-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)))
+ ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2))))))
+ (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05)))))))
+ (standard-path-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
(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?)))
+ ((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?))
+ ((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))))
+ 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)))
+ (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))))))
+ ((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)
;; 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)
+ (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 (* 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))))
+ (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)))
+ (column-circle-stencil radius thick fill layout props)))
;;; Flute family stencils
(define flute-lh-b-key-stencil
(standard-path-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))
+ '((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-path-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))
+ '((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-path-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))))
+ '((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-ees-key-stencil
(standard-path-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))
+ '((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))))))
+ 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-path-stencil
- '((0 0.75) (-0.8 0.75 -0.8 0 0 0))
- flute-lower-row-stretch
- flute-lower-row-stretch))
+ '((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-path-stencil
- '((0 0.75) (0.4 0.75) (0.4 0) (0 0))
- flute-lower-row-stretch
- flute-lower-row-stretch))
+ '((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-path-stencil
- '((0 0.75) (0.25 0.75) (0.25 0) (0 0))
- flute-lower-row-stretch
- flute-lower-row-stretch))
+ '((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-path-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))))
+ '((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
+ ((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
+ `((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))))
+ `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0))
+ 0.2))))
(if gis?
- (standard-path-stencil
- (append
+ (standard-path-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.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-path-stencil
- (map (lambda (l)
- (flatten-list
+ scaling-factor
+ scaling-factor)
+ (standard-path-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)))))
+ `(,(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-ees-lh-bes-key-stencil ees?)
(standard-path-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))
+ `((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-octave-key-stencil long?)
(let* ((h (if long? 1.4 1.2)))
(standard-path-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)))
+ `((-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-rh-c-rh-ees-key-stencil c?)
(rich-path-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))))
+ '((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-cis-key-stencil
(rich-path-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))))
+ '((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))
(define clarinet-lh-R-key-stencil
(let* ((halfbase (cos (/ PI 10)))
- (height (*
- halfbase
- (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
- (standard-path-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)))
+ (height (*
+ halfbase
+ (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10))))))
+ (standard-path-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
+ (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-rh-low-c-key-stencil
(standard-path-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))
+ '((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-path-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))
+ '((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-path-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))
+ '((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-fis-key-stencil
(standard-path-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))
+ `(,(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-gis-key-stencil
(standard-path-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))
+ '((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-e-key-stencil
(standard-path-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))
+ `(,(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-f-key-stencil clarinet-rh-gis-key-stencil)
(define bass-clarinet-rh-ees-key-stencil
(standard-path-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)))
+ `(,(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-ees-key-stencil clarinet-rh-e-key-stencil)
(define saxophone-lh-gis-key-stencil
(standard-path-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))
+ '((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-path-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))
+ '((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-low-bes-key-stencil
(standard-path-stencil
- '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
- 0.8
- 0.8))
+ '((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-path-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))
+ `((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-high-fis-key-stencil
(standard-path-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))
+ (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-low-c-key-stencil
(standard-path-stencil
- '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0))
- 0.8
- 0.8))
+ '((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))))))
+ 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
+ (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)))
+ (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)))
+ (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?)
+ first-bezier
+ second-bezier
+ slope-offset1
+ slope-offset2
+ keylen
+ bezier?)
(append
- `((,(+ keylen (list-ref first-bezier 6))
- ,(+
+ `((,(+ 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 (list-ref first-bezier 6))) (cdr slope-offset1))))
- ((if bezier? (lambda (x) `(,(apply append x))) identity)
- `((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
+ (+ (+ keylen 1.75) (list-ref first-bezier 6)))
+ (cdr slope-offset1)))
+ (,(+ (+ keylen 1.75) (list-ref second-bezier 0))
,(+
- (*
- (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 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))))
+ (* (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-path-stencil
- (append
+ (first-bezier (car info-list))
+ (second-bezier (cadr info-list))
+ (slope-offset1 (caddr info-list))
+ (slope-offset2 (cadddr info-list)))
+ (rich-path-stencil
+ (append
`((0.0 ,(+ height gap))
- ,(list-tail first-bezier 2))
+ ,(list-tail first-bezier 2))
(make-tilted-portion
- first-bezier
- second-bezier
- slope-offset1
- slope-offset2
- keylen
- bezier?)
+ 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)))
+ (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-lh-ees-key-stencil
(rich-e-stencil
- 1.2
- 0.6
+ 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))))
+ 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-ld-key-stencil
(standard-path-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))
+ '((-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-path-stencil
- `((0.0 ,height)
+ `((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)))
+ -1.0
+ -1.0)))
(define bassoon-lh-c-flick-key-stencil
(let ((height 3.0))
(standard-path-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)))
+ `((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-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))
+ 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-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-path-stencil
- (append
+ (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-path-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))
+ (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)))
+ -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 a display method for a music type and store it in the
`display-methods' property of the music type entry found in the
`music-name-to-property-table' hash table. Print methods previously
-defined for that music type are lost.
+defined for that music type are lost.
Syntax: (define-display-method MusicType (expression parser)
- ...body...))"
+ ...body...))"
`(let ((type-props (hashq-ref music-name-to-property-table
- ',music-type '()))
- (method (lambda ,vars
- ,@body)))
+ ',music-type '()))
+ (method (lambda ,vars
+ ,@body)))
(set! type-props
- (assoc-set! type-props 'display-methods (list method)))
+ (assoc-set! type-props 'display-methods (list method)))
(hashq-set! music-name-to-property-table
- ',music-type
- type-props)
+ ',music-type
+ type-props)
method))
(define-macro (define-extra-display-method music-type vars . body)
This new method should return a string or #f. If #f is returned, the next
display method will be called."
`(let* ((type-props (hashq-ref music-name-to-property-table
- ',music-type '()))
- (methods (assoc-ref type-props 'display-methods))
- (new-method (lambda ,vars
- ,@body)))
+ ',music-type '()))
+ (methods (assoc-ref type-props 'display-methods))
+ (new-method (lambda ,vars
+ ,@body)))
(set! type-props
- (assoc-set! type-props
- 'display-methods
- (cons new-method methods)))
+ (assoc-set! type-props
+ 'display-methods
+ (cons new-method methods)))
(hashq-set! music-name-to-property-table
- ',music-type
- type-props)
+ ',music-type
+ type-props)
new-method))
(define* (tag->lily-string expr #:optional (post-event? #f))
(format #f "~{~a ~}"
- (map (lambda (tag)
- (format #f "~a\\tag #'~a" (if post-event? "-" "") tag))
- (ly:music-property expr 'tags))))
+ (map (lambda (tag)
+ (format #f "~a\\tag #'~a" (if post-event? "-" "") tag))
+ (ly:music-property expr 'tags))))
(define* (tweaks->lily-string expr #:optional (post-event? #f))
(format #f "~{~a ~}"
"Print @var{expr}, a music expression, in LilyPond syntax."
(if (ly:music? expr)
(let* ((music-type (ly:music-property expr 'name))
- (procs (assoc-ref (hashq-ref music-name-to-property-table
- music-type '())
- 'display-methods))
- (result-string (and procs (any (lambda (proc)
- (proc expr parser))
- procs))))
- (if result-string
- (format #f "~a~a~a"
+ (procs (assoc-ref (hashq-ref music-name-to-property-table
+ music-type '())
+ 'display-methods))
+ (result-string (and procs (any (lambda (proc)
+ (proc expr parser))
+ procs))))
+ (if result-string
+ (format #f "~a~a~a"
(tag->lily-string expr (post-event? expr))
(tweaks->lily-string expr (post-event? expr))
- result-string)
- (format #f "%{ Print method not implemented for music type ~a %}"
- music-type)))
+ result-string)
+ (format #f "%{ Print method not implemented for music type ~a %}"
+ music-type)))
(format #f "%{ expecting a music expression: ~a %}" expr)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Music pattern matching
-;;;
+;;;
(define (var? x)
(and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0))))
(define (music-or-var-list? x)
(and (pair? x)
(every (lambda (e)
- (or (music? e) (var? e)))
- x)))
+ (or (music? e) (var? e)))
+ x)))
(define (key-val-list->alist lst)
(define (key-val-list->alist-aux lst prev-result)
(if (null? lst)
- prev-result
- (key-val-list->alist-aux (cddr lst)
- (cons (cons (first lst) (second lst))
- prev-result))))
+ prev-result
+ (key-val-list->alist-aux (cddr lst)
+ (cons (cons (first lst) (second lst))
+ prev-result))))
(reverse! (key-val-list->alist-aux lst (list))))
(define (gen-condition expr pattern)
Generate an form that checks if the properties of `expr'
match thoses described in `pattern'."
(let* (;; all (property . value) found at the first depth in pattern,
- ;; including a (name . <Musictype>) pair.
- (pat-all-props (cons (cons 'name (second pattern))
- (key-val-list->alist (cddr pattern))))
- ;; all (property . value) pairs found in pattern, where value is not
- ;; a ?var, a music expression or a music list.
- (prop-vals (remove (lambda (kons)
- (or (var? (cdr kons))
- (music? (cdr kons))
- (music-or-var-list? (cdr kons))))
- pat-all-props))
- ;; list of (property . element) pairs, where element is a music expression
- (element-list (filter (lambda (kons) (music? (cdr kons)))
- pat-all-props))
- ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
- ;; list a music expressions
- (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
- pat-all-props)))
- `(and
+ ;; including a (name . <Musictype>) pair.
+ (pat-all-props (cons (cons 'name (second pattern))
+ (key-val-list->alist (cddr pattern))))
+ ;; all (property . value) pairs found in pattern, where value is not
+ ;; a ?var, a music expression or a music list.
+ (prop-vals (remove (lambda (kons)
+ (or (var? (cdr kons))
+ (music? (cdr kons))
+ (music-or-var-list? (cdr kons))))
+ pat-all-props))
+ ;; list of (property . element) pairs, where element is a music expression
+ (element-list (filter (lambda (kons) (music? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
+ ;; list a music expressions
+ (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
+ pat-all-props)))
+ `(and
;; a form that checks that `expr' is a music expression
;; before actually accessing its properties...
(ly:music? ,expr)
;; a form that checks that `expr' properties have the same
;; values as those given in `pattern'
,@(map (lambda (prop-val)
- (let ((prop (car prop-val))
- (val (cdr prop-val)))
- `(and (not (null? (ly:music-property ,expr ',prop)))
- (equal? (ly:music-property ,expr ',prop) ,val))))
- prop-vals)
+ (let ((prop (car prop-val))
+ (val (cdr prop-val)))
+ `(and (not (null? (ly:music-property ,expr ',prop)))
+ (equal? (ly:music-property ,expr ',prop) ,val))))
+ prop-vals)
;; build the test condition for each element found in a (property . element) pair.
;; (typically, property will be 'element)
,@(map (lambda (prop-element)
- (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element)))
- element-list)
+ (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element)))
+ element-list)
;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair.
;; this requires accessing to an element of a list, hence the index.
;; (typically, property will be 'elements)
,@(map (lambda (prop-elements)
- (let ((ges (gensym))
- (index -1))
- `(and ,@(map (lambda (e)
- (set! index (1+ index))
- (if (music? e)
- (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
- ,index)
- (list-ref (ly:music-property ,expr ',(car prop-elements))
- ,index))
- e)
- #t))
- (cdr prop-elements)))))
- elements-list))))
+ (let ((ges (gensym))
+ (index -1))
+ `(and ,@(map (lambda (e)
+ (set! index (1+ index))
+ (if (music? e)
+ (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
+ ,index)
+ (list-ref (ly:music-property ,expr ',(car prop-elements))
+ ,index))
+ e)
+ #t))
+ (cdr prop-elements)))))
+ elements-list))))
(define (gen-bindings expr pattern)
"Helper function for `with-music-match'.
Generate binding forms by looking for ?var symbol in pattern."
(let* (;; all (property . value) found at the first depth of pattern,
- ;; including a (name . <Musictype>) pair.
- (pat-all-props (cons (cons 'name (second pattern))
- (key-val-list->alist (cddr pattern))))
- ;; all (property . ?var) pairs
- (prop-vars (filter (lambda (kons) (var? (cdr kons)))
- pat-all-props))
- ;; list of (property . element) pairs, where element is a music expression
- (element-list (filter (lambda (kons) (music? (cdr kons)))
- pat-all-props))
- ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
- ;; list a music expressions
- (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
- pat-all-props)))
- (append
+ ;; including a (name . <Musictype>) pair.
+ (pat-all-props (cons (cons 'name (second pattern))
+ (key-val-list->alist (cddr pattern))))
+ ;; all (property . ?var) pairs
+ (prop-vars (filter (lambda (kons) (var? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . element) pairs, where element is a music expression
+ (element-list (filter (lambda (kons) (music? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
+ ;; list a music expressions
+ (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
+ pat-all-props)))
+ (append
;; the binding form for the ?var variable found in pattern (first depth).
;; ?var is bound to the value of `expr' property
(map (lambda (prop-var)
- `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var))))
- prop-vars)
+ `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var))))
+ prop-vars)
;; generate bindings for each element found in a (property . element) pair.
;; (typically, property will be 'element)
(append-map (lambda (prop-element)
- (gen-bindings `(ly:music-property ,expr ',(car prop-element))
- (cdr prop-element)))
- element-list)
+ (gen-bindings `(ly:music-property ,expr ',(car prop-element))
+ (cdr prop-element)))
+ element-list)
;; generate bindings for each element found in a (property . (e1 e2 ...)) pair
;; (typically, property will be 'elements)
- (append-map (lambda (prop-elements)
- (let ((index -1))
- (append-map (lambda (e)
- (set! index (1+ index))
- (if (var? e)
- `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
- (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
- ,index)
- e)))
- (cdr prop-elements))))
- elements-list))))
+ (append-map (lambda (prop-elements)
+ (let ((index -1))
+ (append-map (lambda (e)
+ (set! index (1+ index))
+ (if (var? e)
+ `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
+ (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
+ ,index)
+ e)))
+ (cdr prop-elements))))
+ elements-list))))
(define-macro (with-music-match music-expr+pattern . body)
"If `music-expr' matches `pattern', call `body'. `pattern' should look like:
property ?var1
element (music <MusicType> ...)
elements ((music <MusicType> ...)
- ?var2
- (music <MusicType> ...)))
+ ?var2
+ (music <MusicType> ...)))
The properties of `music-expr' are checked against the values given in the
pattern (the name property being the <MusicType> symbol after the `music'
keyword), then all music expression found in its properties (such as 'element
or 'elements).
When ?var is found instead of a property value, ?var is bound that property value,
-as read inside `music-expr'. ?var may also be used to refere to a whole music
-expression inside an elements list for instance. These bindings are accessible
+as read inside `music-expr'. ?var may also be used to refere to a whole music
+expression inside an elements list for instance. These bindings are accessible
inside body."
(let ((music-expr (first music-expr+pattern))
- (pattern (second music-expr+pattern))
- (expr-sym (gensym)))
+ (pattern (second music-expr+pattern))
+ (expr-sym (gensym)))
`(let ((,expr-sym ,music-expr))
(if ,(gen-condition expr-sym pattern)
- (let ,(gen-bindings expr-sym pattern)
- ,@body)
- #f))))
+ (let ,(gen-bindings expr-sym pattern)
+ ,@body)
+ #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(define make-music-type-predicate-aux
(lambda (mtypes)
(lambda (expr)
- (if (null? mtypes)
- #f
- (or (eqv? (car mtypes) (ly:music-property expr 'name))
- ((make-music-type-predicate-aux (cdr mtypes)) expr))))))
- (make-music-type-predicate-aux music-types))
+ (if (null? mtypes)
+ #f
+ (or (eqv? (car mtypes) (ly:music-property expr 'name))
+ ((make-music-type-predicate-aux (cdr mtypes)) expr))))))
+ (make-music-type-predicate-aux music-types))
(ly:load "define-music-display-methods.scm")
-
(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))))
+ . ,(map (lambda (name element)
+ `(,name . ,element))
+ parameter-list
+ (list-tail list-to-translate 1))))
ls)))
(define (get-named-spreadsheet-column column spreadsheet)
@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))
+ (lambda (row) (cons (car row) (assoc-get column (cdr row))))
+ spreadsheet))
(define make-key-alist
(make-named-spreadsheet '(name offset graphical textual)))
(define (make-central-column-hole-addresses keys)
"Takes @code{keys} and ascribes them to the central column."
(map
- (lambda (key) `(central-column . ,key))
- keys))
+ (lambda (key) `(central-column . ,key))
+ keys))
(define (make-key-symbols hand)
"Takes @code{hand} and ascribes @code{key} to it."
(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-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))))
+ . (((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)))
+ '(ees cis c)))
(,rich-group-draw-rule ((right-hand . gz))
,(make-right-hand-key-addresses
- '(ees cis c b)))))
+ '(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))
(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
+ 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
+ (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))))))))))
+ (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 (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))))))))))
+ ((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 (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))))))))))
+ ((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
- . (()
- ((ees
- . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
- (stencil . ,bass-clarinet-rh-ees-key-stencil)
- (text? . ("E" . 0))
- (complexity . trill))))
- ((ees
- . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
- (stencil . ,low-bass-clarinet-rh-ees-key-stencil)
- (text? . ("E" . 0))
- (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
+ `((bottom-group-key-names
+ . (()
+ ((ees
+ . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,bass-clarinet-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (complexity . trill))))
+ ((ees
+ . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,low-bass-clarinet-rh-ees-key-stencil)
+ (text? . ("E" . 0))
+ (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 f 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 f 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)))))))
+ (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 f 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 f 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)))
- (gis
- . ((offset . (,(+ 1.5 CL-RH-HAIR)
- . ,(* 3 (+ 0.75 CL-RH-HAIR))))
- (stencil . ,clarinet-rh-gis-key-stencil)
- (text? . ("G" . 1))
- (complexity . trill)))
- (e
- . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR))))
- (stencil . ,clarinet-rh-e-key-stencil)
- (text? . ("E" . #f))
- (complexity . trill)))
- (f
- . ((offset . (,(+ 1.5 CL-RH-HAIR)
- . ,(* 1 (+ 0.75 CL-RH-HAIR))))
- (stencil . ,clarinet-rh-f-key-stencil)
- (text? . ("F" . #f))
- (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
+ ((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)))
+ (gis
+ . ((offset . (,(+ 1.5 CL-RH-HAIR)
+ . ,(* 3 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-gis-key-stencil)
+ (text? . ("G" . 1))
+ (complexity . trill)))
+ (e
+ . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-e-key-stencil)
+ (text? . ("E" . #f))
+ (complexity . trill)))
+ (f
+ . ((offset . (,(+ 1.5 CL-RH-HAIR)
+ . ,(* 1 (+ 0.75 CL-RH-HAIR))))
+ (stencil . ,clarinet-rh-f-key-stencil)
+ (text? . ("F" . #f))
+ (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
+ ,(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
+ (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))))))))))
+ (,uniform-extra-offset-rule (0.0 . 0.0))))))))))
;; Saxophone assembly instructions
(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-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)))))
+ . (()
+ (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0)))))
(low-a-presence
- . (()
- ((left-hand . low-a))))
+ . (()
+ ((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)))))))
+ . (,(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
+ ((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))))))))))
+ (,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-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 . 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))))
+ (((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)))
- ()))
+ (((,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 . thumb-gis) (right-hand . thumb-fis))
+ ((right-hand . thumb-fis))))
(right-hand-cis-key .
- ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22)))
- ()))
+ ((,(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)))
+ ((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)))
+ ((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))))))
+ ((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
+ ((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
+ (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
+ (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
+ (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
+ ,(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))))))))))
+ ,(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
(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 (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)))))
+ ((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
+ (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))))
+ ,(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
+ (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))))
+ (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))))
+ (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)
(define
(assemble-stencils
- stencil-alist
- key-bank
- draw-instructions
- extra-offset-instructions
- radius
- thick
- xy-stretch
- layout
- props)
+ 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))
+ 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)))
+ radius
+ thick
+ (assoc-get node draw-instructions)
+ layout
+ props)))
+ (coord-scale
+ (coord-translate
(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))))
+ (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 #:optional (port (current-output-port)))
(format port "\nPrinting keys for: ~a\n" instrument)
(let ((chosen-instrument (assoc-get instrument woodwind-data-alist)))
- (do ((key-list
- (list-all-possible-keys (assoc-get 'keys chosen-instrument))
- (cdr key-list)))
- ((null? key-list))
+ (do ((key-list
+ (list-all-possible-keys (assoc-get 'keys chosen-instrument))
+ (cdr key-list)))
+ ((null? key-list))
(format port "~a\n ~a\n" (caar key-list) (cdar key-list)))))
(define-public (get-woodwind-key-list instrument)
(list-all-possible-keys-verbose
- (assoc-get
- 'keys
- (assoc-get instrument woodwind-data-alist))))
+ (assoc-get
+ 'keys
+ (assoc-get instrument woodwind-data-alist))))
(define*-public (print-keys-verbose instrument
- #:optional (port (current-output-port)))
+ #:optional (port (current-output-port)))
(format port "\nPrinting keys in verbose mode for: ~a\n" instrument)
(do ((key-list (get-woodwind-key-list instrument)
- (cdr key-list)))
+ (cdr key-list)))
((null? key-list))
(format port "~a\n" (caar key-list))
(for-each
(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))
+ (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))
+ (assoc-get
+ (if display-graphic 'graphical-commands 'text-commands)
+ chosen-instrument))
(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))))
+ (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)))
+ (function-chain
+ pressed-info
+ (assoc-get 'draw-instructions stencil-info)))
(extra-offset-info
- (function-chain
- pressed-info
- (assoc-get 'extra-offset-instructions stencil-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)))
+ (assoc-get 'stencil-alist stencil-info)
+ (assoc-get 'keys chosen-instrument)
+ draw-info
+ extra-offset-info
+ radius
+ thick
+ xy-stretch
+ layout
+ props)))
;; properly sort all grobs, properties, and interfaces
;; within the all-grob-descriptions alist
(map
- (lambda (x)
- (let* ((props (assoc-ref all-grob-descriptions (car x)))
- (meta (assoc-ref props 'meta))
- (interfaces (assoc-ref meta 'interfaces)))
- (set! all-grob-descriptions
- (sort (assoc-set! all-grob-descriptions (car x)
- (sort-grob-properties
- (assoc-set! props 'meta
- (assoc-set! meta 'interfaces
- (sort interfaces ly:symbol-ci<?)))))
- ly:alist-ci<?))))
- all-grob-descriptions)
+ (lambda (x)
+ (let* ((props (assoc-ref all-grob-descriptions (car x)))
+ (meta (assoc-ref props 'meta))
+ (interfaces (assoc-ref meta 'interfaces)))
+ (set! all-grob-descriptions
+ (sort (assoc-set! all-grob-descriptions (car x)
+ (sort-grob-properties
+ (assoc-set! props 'meta
+ (assoc-set! meta 'interfaces
+ (sort interfaces ly:symbol-ci<?)))))
+ ly:alist-ci<?))))
+ all-grob-descriptions)
(define (interface-doc-string interface grob-description)
(let* ((name (car interface))
- (desc (cadr interface))
- (props (caddr interface))
- (docfunc (lambda (pr)
- (property->texi
- 'backend pr grob-description)))
- (iprops (filter (lambda (x) (object-property x 'backend-internal))
- props))
- (uprops (filter
- (lambda (x) (not (object-property x 'backend-internal)))
- props))
- (user-propdocs (map docfunc uprops))
- (internal-propdocs (map docfunc iprops)))
+ (desc (cadr interface))
+ (props (caddr interface))
+ (docfunc (lambda (pr)
+ (property->texi
+ 'backend pr grob-description)))
+ (iprops (filter (lambda (x) (object-property x 'backend-internal))
+ props))
+ (uprops (filter
+ (lambda (x) (not (object-property x 'backend-internal)))
+ props))
+ (user-propdocs (map docfunc uprops))
+ (internal-propdocs (map docfunc iprops)))
(string-append
desc
(if (pair? uprops)
- (string-append
- "\n\n@subsubheading User settable properties:\n"
- (description-list->texi user-propdocs #t))
- "")
+ (string-append
+ "\n\n@subsubheading User settable properties:\n"
+ (description-list->texi user-propdocs #t))
+ "")
(if (pair? iprops)
- (string-append
- "\n\n@subsubheading Internal properties:\n"
- (description-list->texi internal-propdocs #t))
- ""))))
+ (string-append
+ "\n\n@subsubheading Internal properties:\n"
+ (description-list->texi internal-propdocs #t))
+ ""))))
(define iface->grob-table (make-hash-table 61))
;; extract ifaces, and put grob into the hash table.
(map
(lambda (x)
(let* ((meta (assoc-get 'meta (cdr x)))
- (ifaces (assoc-get 'interfaces meta)))
+ (ifaces (assoc-get 'interfaces meta)))
(map (lambda (iface)
- (hashq-set!
- iface->grob-table iface
- (cons (car x)
- (hashq-ref iface->grob-table iface '()))))
- ifaces)))
+ (hashq-set!
+ iface->grob-table iface
+ (cons (car x)
+ (hashq-ref iface->grob-table iface '()))))
+ ifaces)))
all-grob-descriptions)
;; First level Interface description
(define (interface-doc interface)
(let* ((name (symbol->string (car interface)))
- (interface-list (human-listify
- (map ref-ify
- (sort
- (map symbol->string
- (hashq-ref iface->grob-table
- (car interface)
- '()))
- ly:string-ci<?)))))
+ (interface-list (human-listify
+ (map ref-ify
+ (sort
+ (map symbol->string
+ (hashq-ref iface->grob-table
+ (car interface)
+ '()))
+ ly:string-ci<?)))))
(make <texi-node>
#:name name
#:text (string-append
- (interface-doc-string (cdr interface) '())
- "\n\n"
- "This grob interface "
- (if (equal? interface-list "none")
- "is not used in any graphical object"
- (string-append
- "is used in the following graphical object(s): "
- interface-list))
- "."))))
+ (interface-doc-string (cdr interface) '())
+ "\n\n"
+ "This grob interface "
+ (if (equal? interface-list "none")
+ "is not used in any graphical object"
+ (string-append
+ "is used in the following graphical object(s): "
+ interface-list))
+ "."))))
(define (grob-alist->texi alist)
(let* ((uprops (filter (lambda (x) (not (object-property x 'backend-internal)))
- (map car alist))))
+ (map car alist))))
(description-list->texi
(map (lambda (y) (property->texi 'backend y alist))
- uprops)
+ uprops)
#t)))
(define (grob-doc description)
node."
(let* ((meta (assoc-get 'meta description))
- (name (assoc-get 'name meta))
- ;; (bla (display name))
- (ifaces (map lookup-interface (assoc-get 'interfaces meta)))
- (ifacedoc (map ref-ify
- (sort
- (map (lambda (iface)
- (if (pair? iface)
- (symbol->string (car iface))
- (ly:error (_ "pair expected in doc ~s") name)))
- ifaces)
- ly:string-ci<?)))
- (engravers (filter
- (lambda (x) (engraver-makes-grob? name x))
- all-engravers-list))
- (namestr (symbol->string name))
- (engraver-names (map symbol->string
- (map ly:translator-name engravers)))
- (engraver-list (human-listify
- (map ref-ify
- (map engraver-name engraver-names)))))
+ (name (assoc-get 'name meta))
+ ;; (bla (display name))
+ (ifaces (map lookup-interface (assoc-get 'interfaces meta)))
+ (ifacedoc (map ref-ify
+ (sort
+ (map (lambda (iface)
+ (if (pair? iface)
+ (symbol->string (car iface))
+ (ly:error (_ "pair expected in doc ~s") name)))
+ ifaces)
+ ly:string-ci<?)))
+ (engravers (filter
+ (lambda (x) (engraver-makes-grob? name x))
+ all-engravers-list))
+ (namestr (symbol->string name))
+ (engraver-names (map symbol->string
+ (map ly:translator-name engravers)))
+ (engraver-list (human-listify
+ (map ref-ify
+ (map engraver-name engraver-names)))))
(make <texi-node>
#:name namestr
(string-append
namestr " objects "
(if (equal? engraver-list "none")
- "are not created by any engraver"
- (string-append
- "are created by: "
- engraver-list))
+ "are not created by any engraver"
+ (string-append
+ "are created by: "
+ engraver-list))
"."
"\n\nStandard settings:\n\n"
'() (ly:all-grob-interfaces)))
(set! interface-description-alist
- (sort interface-description-alist ly:alist-ci<?))
+ (sort interface-description-alist ly:alist-ci<?))
;;;;;;;;;; check for dangling backend properties.
(define (mark-interface-properties entry)
(define (check-dangling-properties prop)
(if (not (object-property prop 'iface-marked))
(ly:error (string-append "define-grob-properties.scm: "
- (_ "cannot find interface for property: ~S")) prop)))
+ (_ "cannot find interface for property: ~S")) prop)))
(map check-dangling-properties all-backend-properties)
(define (lookup-interface name)
(let* ((entry (hashq-ref (ly:all-grob-interfaces) name #f)))
(if entry
- entry
- (ly:error (_ "unknown Grob interface: ~S") name))))
+ entry
+ (ly:error (_ "unknown Grob interface: ~S") name))))
(define (all-interfaces-doc)
(make <texi-node>
(define (backend-properties-doc-string lst)
(let* ((ps (sort (map symbol->string lst) ly:string-ci<?))
- (descs (map (lambda (prop)
- (property->texi 'backend (string->symbol prop) '())) ps))
- (texi (description-list->texi descs #f)))
+ (descs (map (lambda (prop)
+ (property->texi 'backend (string->symbol prop) '())) ps))
+ (texi (description-list->texi descs #f)))
texi))
;;(dump-node (grob-doc (cdadr all-grob-descriptions)) (current-output-port) 0 )
"
name-sym
name-sym
- (if (pair? docstring)
- (cadar docstring)
+ (if (pair? docstring)
+ (cadar docstring)
(begin
(ly:warning "context modification `~a' not documented." name-sym)
"(undocumented; fixme)"))
(ice-9 regex))
(define (dashify-underscores str)
- (regexp-substitute/global #f "_" str 'pre "-" 'post))
+ (regexp-substitute/global #f "_" str 'pre "-" 'post))
(define (format-c-header c-h)
(regexp-substitute/global
- #f ","
+ #f ","
(regexp-substitute/global #f "(SCM|\\)|\\() *" (dashify-underscores c-h)
- 'pre "" 'post)
+ 'pre "" 'post)
'pre " " 'post))
(define (document-scheme-function name c-header doc-string)
"\n@end defun\n\n"))
(define all-scheme-functions
- (hash-fold
- (lambda (key val prior)
- (cons (cons key val) prior))
- '() (ly:get-all-function-documentation)))
+ (hash-fold
+ (lambda (key val prior)
+ (cons (cons key val) prior))
+ '() (ly:get-all-function-documentation)))
(define (all-scheme-functions-doc)
(let* ((fdocs (map (lambda (x)
- (document-scheme-function (car x) (cadr x) (cddr x)))
- all-scheme-functions))
- (sfdocs (sort fdocs ly:string-ci<?)))
+ (document-scheme-function (car x) (cadr x) (cddr x)))
+ all-scheme-functions))
+ (sfdocs (sort fdocs ly:string-ci<?)))
(make <texi-node>
#:name "Scheme functions"
#:desc "Primitive functions exported by LilyPond."
(music-func (cdr music-func-pair))
(func (ly:music-function-extract music-func))
(arg-names
- (map symbol->string
- (cddr (cadr (procedure-source func)))))
+ (map symbol->string
+ (cddr (cadr (procedure-source func)))))
(doc (procedure-documentation func))
(sign (ly:music-function-signature music-func))
(type-names (map (lambda (pred)
- (if (pair? pred)
- (format #f "[~a]" (type-name (car pred)))
- (format #f "(~a)" (type-name pred))))
- sign))
+ (if (pair? pred)
+ (format #f "[~a]" (type-name (car pred)))
+ (format #f "(~a)" (type-name pred))))
+ sign))
(signature-str
- (string-join
- (map (lambda (arg type) (format #f "@var{~a} ~a" arg type))
- arg-names (cdr type-names)))))
+ (string-join
+ (map (lambda (arg type) (format #f "@var{~a} ~a" arg type))
+ arg-names (cdr type-names)))))
(format #f
- "@item @code{~a} ~a ~a~a
+ "@item @code{~a} ~a ~a~a
@funindex ~a
~a
"
- name-sym (car type-names)
- (if (equal? "" signature-str) "" " - ") signature-str
- name-sym
- (if doc
- doc
- (begin
- (ly:warning "music function `~a' not documented." name-sym)
- "(undocumented; fixme)")))))
+ name-sym (car type-names)
+ (if (equal? "" signature-str) "" " - ") signature-str
+ name-sym
+ (if doc
+ doc
+ (begin
+ (ly:warning "music function `~a' not documented." name-sym)
+ "(undocumented; fixme)")))))
(define (document-object obj-pair)
(define-public (identifiers-doc-string)
(format #f
- "@table @asis
+ "@table @asis
~a
@end table
"
- (string-join
- (filter
- identity
- (map
- document-object
- (sort
- (ly:module->alist (current-module))
- identifier<?)))
- "")))
+ (string-join
+ (filter
+ identity
+ (map
+ document-object
+ (sort
+ (ly:module->alist (current-module))
+ identifier<?)))
+ "")))
(define (markup-category-doc-node category)
(let* ((category-string (symbol->string category))
(category-name (string-capitalize
- (regexp-substitute/global
- #f "-" category-string 'pre " " 'post)))
- (markup-functions (hash-fold (lambda (markup-function dummy functions)
- (cons markup-function functions))
- '()
- (hashq-ref markup-functions-by-category
- category))))
+ (regexp-substitute/global
+ #f "-" category-string 'pre " " 'post)))
+ (markup-functions (hash-fold (lambda (markup-function dummy functions)
+ (cons markup-function functions))
+ '()
+ (hashq-ref markup-functions-by-category
+ category))))
(make <texi-node>
#:appendix #t
#:name category-name
(string-append
"@table @asis"
(apply string-append
- (map doc-markup-function
- (sort (hash-fold (lambda (markup-list-function dummy functions)
- (cons markup-list-function functions))
- '()
- markup-list-functions)
- markup-function<?)))
+ (map doc-markup-function
+ (sort (hash-fold (lambda (markup-list-function dummy functions)
+ (cons markup-list-function functions))
+ '()
+ markup-list-functions)
+ markup-function<?)))
"\n@end table"))
-
-
#:desc "All music properties, including descriptions."
#:text
(let* ((ps (sort (map symbol->string all-music-properties) ly:string-ci<?))
- (descs (map (lambda (prop)
- (property->texi 'music (string->symbol prop)))
- ps))
- (texi (description-list->texi descs #f)))
+ (descs (map (lambda (prop)
+ (property->texi 'music (string->symbol prop)))
+ ps))
+ (texi (description-list->texi descs #f)))
texi)))
(define music-types->names (make-hash-table 61))
(filter-map (lambda (entry)
- (let* ((class (ly:camel-case->lisp-identifier (car entry)))
- (classes (ly:make-event-class doc-context class)))
- (if classes
- (map
- (lambda (cl)
- (hashq-set! music-types->names cl
- (cons (car entry)
- (hashq-ref music-types->names cl '()))))
- classes)
- #f)))
-
- music-descriptions)
+ (let* ((class (ly:camel-case->lisp-identifier (car entry)))
+ (classes (ly:make-event-class doc-context class)))
+ (if classes
+ (map
+ (lambda (cl)
+ (hashq-set! music-types->names cl
+ (cons (car entry)
+ (hashq-ref music-types->names cl '()))))
+ classes)
+ #f)))
+
+ music-descriptions)
(define (strip-description x)
(cons (symbol->string (car x))
- ""))
+ ""))
(define (music-type-doc entry)
(let* ((accept-list (human-listify
- (map ref-ify
- (map symbol->string
- (map ly:translator-name
- (filter
- (lambda (x)
- (engraver-accepts-music-type? (car entry) x))
- all-engravers-list)))))))
+ (map ref-ify
+ (map symbol->string
+ (map ly:translator-name
+ (filter
+ (lambda (x)
+ (engraver-accepts-music-type? (car entry) x))
+ all-engravers-list)))))))
(make <texi-node>
#:name (symbol->string (car entry))
#:text
(symbol->string (car entry))
"} is in music objects of type "
(human-listify
- (map ref-ify (sort (map symbol->string (cdr entry))
- ly:string-ci<?)))
+ (map ref-ify (sort (map symbol->string (cdr entry))
+ ly:string-ci<?)))
"."
"\n\n"
(if (equal? accept-list "none")
- "Not accepted by any engraver or performer"
- (string-append
- "Accepted by: "
- accept-list))
+ "Not accepted by any engraver or performer"
+ (string-append
+ "Accepted by: "
+ accept-list))
"."))))
(define (music-types-doc)
#:name "Music classes"
#:children
(map music-type-doc
- (sort
- (hash-table->alist music-types->names) ly:alist-ci<?))))
+ (sort
+ (hash-table->alist music-types->names) ly:alist-ci<?))))
(define (music-doc-str obj)
(let* ((namesym (car obj))
- (props (cdr obj))
- (class (ly:camel-case->lisp-identifier namesym))
- (classes (ly:make-event-class doc-context class))
- (accept-list (if classes
- (human-listify
- (map ref-ify
- (map symbol->string
- (map ly:translator-name
- (filter
- (lambda (x)
- (engraver-accepts-music-types? classes x))
- all-engravers-list)))))
- ""))
- (event-texi (if classes
- (string-append
- "\n\nEvent classes:\n"
- (human-listify
- (map ref-ify (sort (map symbol->string classes)
- ly:string-ci<?)))
- "."
+ (props (cdr obj))
+ (class (ly:camel-case->lisp-identifier namesym))
+ (classes (ly:make-event-class doc-context class))
+ (accept-list (if classes
+ (human-listify
+ (map ref-ify
+ (map symbol->string
+ (map ly:translator-name
+ (filter
+ (lambda (x)
+ (engraver-accepts-music-types? classes x))
+ all-engravers-list)))))
+ ""))
+ (event-texi (if classes
+ (string-append
+ "\n\nEvent classes:\n"
+ (human-listify
+ (map ref-ify (sort (map symbol->string classes)
+ ly:string-ci<?)))
+ "."
- "\n\n"
- (if (equal? accept-list "none")
- "Not accepted by any engraver or performer"
- (string-append
- "Accepted by: "
- accept-list))
- ".")
- "")))
+ "\n\n"
+ (if (equal? accept-list "none")
+ "Not accepted by any engraver or performer"
+ (string-append
+ "Accepted by: "
+ accept-list))
+ ".")
+ "")))
(string-append
(object-property namesym 'music-description)
(define (engraver-doc-string engraver in-which-contexts)
(let* ((propsr (assoc-get 'properties-read (ly:translator-description engraver)))
- (propsw (assoc-get 'properties-written (ly:translator-description engraver)))
- (accepted (assoc-get 'events-accepted (ly:translator-description engraver)))
- (name-sym (ly:translator-name engraver))
- (name-str (symbol->string name-sym))
- (desc (assoc-get 'description (ly:translator-description engraver)))
- (grobs (engraver-grobs engraver)))
+ (propsw (assoc-get 'properties-written (ly:translator-description engraver)))
+ (accepted (assoc-get 'events-accepted (ly:translator-description engraver)))
+ (name-sym (ly:translator-name engraver))
+ (name-str (symbol->string name-sym))
+ (desc (assoc-get 'description (ly:translator-description engraver)))
+ (grobs (engraver-grobs engraver)))
(string-append
desc
"\n\n"
(if (pair? accepted)
- (string-append
- "Music types accepted:\n\n"
- (human-listify
- (map ref-ify (sort (map symbol->string accepted) ly:string-ci<?))))
- "")
+ (string-append
+ "Music types accepted:\n\n"
+ (human-listify
+ (map ref-ify (sort (map symbol->string accepted) ly:string-ci<?))))
+ "")
"\n\n"
(if (pair? propsr)
- (string-append
- "Properties (read)"
- (description-list->texi
- (map (lambda (x) (property->texi 'translation x '()))
- (sort propsr ly:symbol-ci<?))
- #t))
- "")
+ (string-append
+ "Properties (read)"
+ (description-list->texi
+ (map (lambda (x) (property->texi 'translation x '()))
+ (sort propsr ly:symbol-ci<?))
+ #t))
+ "")
(if (null? propsw)
- ""
- (string-append
- "Properties (write)"
- (description-list->texi
- (map (lambda (x) (property->texi 'translation x '()))
- (sort propsw ly:symbol-ci<?))
- #t)))
+ ""
+ (string-append
+ "Properties (write)"
+ (description-list->texi
+ (map (lambda (x) (property->texi 'translation x '()))
+ (sort propsw ly:symbol-ci<?))
+ #t)))
(if (null? grobs)
- ""
- (string-append
- "\n\nThis engraver creates the following layout object(s):\n\n"
- (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?))))
- "."))
+ ""
+ (string-append
+ "\n\nThis engraver creates the following layout object(s):\n\n"
+ (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?))))
+ "."))
"\n\n"
(if in-which-contexts
- (let* ((layout-alist (ly:output-description $defaultlayout))
- (context-description-alist (map cdr layout-alist))
- (contexts
- (apply append
- (map
- (lambda (x)
- (let* ((context (assoc-get 'context-name x))
- (group (assq-ref x 'group-type))
- (consists (append
- (if group
- (list group)
- '())
- (assoc-get 'consists x))))
- (if (member name-sym consists)
- (list context)
- '())))
- context-description-alist)))
- (context-list (human-listify (map ref-ify
- (sort
- (map symbol->string contexts)
- ly:string-ci<?)))))
- (string-append
- "@code{" name-str "} "
- (if (equal? context-list "none")
- "is not part of any context"
- (string-append
- "is part of the following context(s): "
- context-list))
- "."))
- ""))))
+ (let* ((layout-alist (ly:output-description $defaultlayout))
+ (context-description-alist (map cdr layout-alist))
+ (contexts
+ (apply append
+ (map
+ (lambda (x)
+ (let* ((context (assoc-get 'context-name x))
+ (group (assq-ref x 'group-type))
+ (consists (append
+ (if group
+ (list group)
+ '())
+ (assoc-get 'consists x))))
+ (if (member name-sym consists)
+ (list context)
+ '())))
+ context-description-alist)))
+ (context-list (human-listify (map ref-ify
+ (sort
+ (map symbol->string contexts)
+ ly:string-ci<?)))))
+ (string-append
+ "@code{" name-str "} "
+ (if (equal? context-list "none")
+ "is not part of any context"
+ (string-append
+ "is part of the following context(s): "
+ context-list))
+ "."))
+ ""))))
;; First level Engraver description
(define (engraver-doc grav)
(let* ((eg (find-engraver-by-name name)))
(cons (string-append "@code{" (ref-ify (symbol->string name)) "}")
- (engraver-doc-string eg #f))))
+ (engraver-doc-string eg #f))))
(define (document-property-operation op)
(let ((tag (car op))
- (context-sym (cadr op))
- (args (cddr op))
- )
+ (context-sym (cadr op))
+ (args (cddr op))
+ )
(cond
((equal? tag 'push)
(let*
- ((value (car args))
- (path (cdr args)))
-
- (string-append
- "@item Set "
- (format #f "grob-property @code{~a} "
- (string-join (map symbol->string path) " "))
- (format #f "in @ref{~a} to ~a."
- context-sym (scm->texi value))
- "\n")))
+ ((value (car args))
+ (path (cdr args)))
+
+ (string-append
+ "@item Set "
+ (format #f "grob-property @code{~a} "
+ (string-join (map symbol->string path) " "))
+ (format #f "in @ref{~a} to ~a."
+ context-sym (scm->texi value))
+ "\n")))
((equal? (object-property context-sym 'is-grob?) #t) "")
((equal? tag 'assign)
(format #f "@item Set translator property @code{~a} to ~a.\n"
- context-sym
- (scm->texi (car args))))
+ context-sym
+ (scm->texi (car args))))
)))
(define (context-doc context-desc)
(let* ((name-sym (assoc-get 'context-name context-desc))
- (name (symbol->string name-sym))
- (aliases (map symbol->string (assoc-get 'aliases context-desc)))
- (desc (assoc-get 'description context-desc "(not documented"))
- (accepts (assoc-get 'accepts context-desc))
- (consists (assoc-get 'consists context-desc))
- (props (assoc-get 'property-ops context-desc))
- (grobs (context-grobs context-desc))
- (grob-refs (map ref-ify (sort grobs ly:string-ci<?))))
+ (name (symbol->string name-sym))
+ (aliases (map symbol->string (assoc-get 'aliases context-desc)))
+ (desc (assoc-get 'description context-desc "(not documented"))
+ (accepts (assoc-get 'accepts context-desc))
+ (consists (assoc-get 'consists context-desc))
+ (props (assoc-get 'property-ops context-desc))
+ (grobs (context-grobs context-desc))
+ (grob-refs (map ref-ify (sort grobs ly:string-ci<?))))
(make <texi-node>
#:name name
(string-append
desc
(if (pair? aliases)
- (string-append
- "\n\nThis context also accepts commands for the following context(s):\n\n"
- (human-listify (sort aliases ly:string-ci<?))
- ".")
- "")
+ (string-append
+ "\n\nThis context also accepts commands for the following context(s):\n\n"
+ (human-listify (sort aliases ly:string-ci<?))
+ ".")
+ "")
"\n\nThis context creates the following layout object(s):\n\n"
(human-listify (uniq-list grob-refs))
"."
(if (and (pair? props) (not (null? props)))
- (let ((str (apply string-append
- (sort (map document-property-operation props)
- ly:string-ci<?))))
- (if (string-null? str)
- ""
- (string-append
- "\n\nThis context sets the following properties:\n\n"
- "@itemize @bullet\n"
- str
- "@end itemize\n")))
- "")
+ (let ((str (apply string-append
+ (sort (map document-property-operation props)
+ ly:string-ci<?))))
+ (if (string-null? str)
+ ""
+ (string-append
+ "\n\nThis context sets the following properties:\n\n"
+ "@itemize @bullet\n"
+ str
+ "@end itemize\n")))
+ "")
(if (null? accepts)
- "\n\nThis context is a `bottom' context; it cannot contain other contexts."
- (string-append
- "\n\nContext "
- name
- " can contain\n"
- (human-listify (map ref-ify (sort (map symbol->string accepts)
- ly:string-ci<?)))
- "."))
+ "\n\nThis context is a `bottom' context; it cannot contain other contexts."
+ (string-append
+ "\n\nContext "
+ name
+ " can contain\n"
+ (human-listify (map ref-ify (sort (map symbol->string accepts)
+ ly:string-ci<?)))
+ "."))
(if (null? consists)
- ""
- (string-append
- "\n\nThis context is built from the following engraver(s):"
- (description-list->texi
- (map document-engraver-by-name (sort consists ly:symbol-ci<?))
- #t)))))))
+ ""
+ (string-append
+ "\n\nThis context is built from the following engraver(s):"
+ (description-list->texi
+ (map document-engraver-by-name (sort consists ly:symbol-ci<?))
+ #t)))))))
(define (engraver-grobs grav)
(let* ((eg (if (symbol? grav)
- (find-engraver-by-name grav)
- grav)))
+ (find-engraver-by-name grav)
+ grav)))
(if (eq? eg #f)
- '()
- (map symbol->string (assoc-get 'grobs-created (ly:translator-description eg))))))
+ '()
+ (map symbol->string (assoc-get 'grobs-created (ly:translator-description eg))))))
(define (context-grobs context-desc)
(let* ((group (assq-ref context-desc 'group-type))
- (consists (append
- (if group
- (list group)
- '())
- (assoc-get 'consists context-desc)))
- (grobs (apply append
- (map engraver-grobs consists))))
+ (consists (append
+ (if group
+ (list group)
+ '())
+ (assoc-get 'consists context-desc)))
+ (grobs (apply append
+ (map engraver-grobs consists))))
grobs))
(define (all-contexts-doc)
(let* ((layout-alist
- (sort (ly:output-description $defaultlayout)
- (lambda (x y) (ly:symbol-ci<? (car x) (car y)))))
- (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?))
- (contexts (map cdr layout-alist)))
+ (sort (ly:output-description $defaultlayout)
+ (lambda (x y) (ly:symbol-ci<? (car x) (car y)))))
+ (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?))
+ (contexts (map cdr layout-alist)))
(make <texi-node>
#:name "Contexts"
(define all-engravers-list (ly:get-all-translators))
(set! all-engravers-list
(sort all-engravers-list
- (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a))
- (symbol->string (ly:translator-name b))))))
+ (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a))
+ (symbol->string (ly:translator-name b))))))
(define (all-engravers-doc)
(make <texi-node>
(define (translation-properties-doc-string lst)
(let* ((ps (sort (map symbol->string lst) ly:string-ci<?))
- (sortedsyms (map string->symbol ps))
- (propdescs
- (map
- (lambda (x) (property->texi 'translation x '()))
- sortedsyms))
- (texi (description-list->texi propdescs #f)))
+ (sortedsyms (map string->symbol ps))
+ (propdescs
+ (map
+ (lambda (x) (property->texi 'translation x '()))
+ sortedsyms))
+ (texi (description-list->texi propdescs #f)))
texi))
(define (translation-doc-node)
#:name "Tunable context properties"
#:desc "All tunable context properties."
#:text (translation-properties-doc-string
- all-user-translation-properties))
+ all-user-translation-properties))
(make <texi-node>
#:name "Internal context properties"
#:desc "All internal context properties."
#:text (translation-properties-doc-string
- all-internal-translation-properties)))))
+ all-internal-translation-properties)))))
;; todo: naming: grob vs. layout property
(map ly:load '("documentation-lib.scm"
- "lily-sort.scm"
- "document-functions.scm"
- "document-translation.scm"
- "document-music.scm"
- "document-type-predicates.scm"
- "document-identifiers.scm"
- "document-context-mods.scm"
- "document-backend.scm"
- "document-markup.scm"))
+ "lily-sort.scm"
+ "document-functions.scm"
+ "document-translation.scm"
+ "document-music.scm"
+ "document-type-predicates.scm"
+ "document-identifiers.scm"
+ "document-context-mods.scm"
+ "document-backend.scm"
+ "document-markup.scm"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(display
(string-append
(texi-file-head "LilyPond Internals Reference" file-name
- "(lilypond-internals.info)")
+ "(lilypond-internals.info)")
"
@include macros.itexi
@end ifhtml
This is the Internals Reference (IR) for version "
- (lilypond-version)
- " of LilyPond, the GNU music typesetter.")
+ (lilypond-version)
+ " of LilyPond, the GNU music typesetter.")
#:children
(list
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
(use-modules (oop goops)
- (srfi srfi-13)
- (srfi srfi-1))
+ (srfi srfi-13)
+ (srfi srfi-1))
(define-class <texi-node> ()
(appendix #:init-value #f #:accessor appendix? #:init-keyword #:appendix)
(node-text node)
"\n\n"
(if (pair? (node-children node))
- (texi-menu
- (map (lambda (x) (menu-entry x))
- (node-children node)))
- ""))
+ (texi-menu
+ (map (lambda (x) (menu-entry x))
+ (node-children node)))
+ ""))
port)
(map (lambda (x) (dump-node x port (+ 1 level)))
(node-children node)))
(define (texi-section-command level)
(assoc-get level '(
- ;; Hmm, texinfo doesn't have ``part''
- (0 . "@top")
- (1 . "@chapter")
- (2 . "@section")
- (3 . "@subsection")
- (4 . "@unnumberedsubsubsec")
- (5 . "@unnumberedsubsubsec"))))
+ ;; Hmm, texinfo doesn't have ``part''
+ (0 . "@top")
+ (1 . "@chapter")
+ (2 . "@section")
+ (3 . "@subsection")
+ (4 . "@unnumberedsubsubsec")
+ (5 . "@unnumberedsubsubsec"))))
(define (texi-appendix-section-command level)
(assoc-get level '((0 . "@top")
- (1 . "@appendix")
- (2 . "@appendixsec")
- (3 . "@appendixsubsec")
- (4 . "@appendixsubsubsec")
- (5 . "@appendixsubsubsec"))))
+ (1 . "@appendix")
+ (2 . "@appendixsec")
+ (3 . "@appendixsubsec")
+ (4 . "@appendixsubsubsec")
+ (5 . "@appendixsubsubsec"))))
(define (one-item->texi label-desc-pair)
"Document one (LABEL . DESC); return empty string if LABEL is empty string."
(define (texi-menu items-alist)
"Generate what is between @menu and @end menu."
(let ((maxwid
- (apply max (map (lambda (x) (string-length (car x))) items-alist))))
+ (apply max (map (lambda (x) (string-length (car x))) items-alist))))
(string-append
"\n@menu"
(apply string-append
- (map (lambda (x)
- (string-append
- (string-pad-right
- (string-append "\n* " (car x) ":: ")
- (+ maxwid 8))
- (cdr x)))
- items-alist))
+ (map (lambda (x)
+ (string-append
+ (string-pad-right
+ (string-append "\n* " (car x) ":: ")
+ (+ maxwid 8))
+ (cdr x)))
+ items-alist))
"\n@end menu\n"
;; Menus don't appear in html, so we make a list ourselves
"\n@ignore\n"
"\n@ifhtml\n"
(description-list->texi (map (lambda (x) (cons (ref-ify (car x)) (cdr x)))
- items-alist)
- #t)
+ items-alist)
+ #t)
"\n@end ifhtml\n"
"\n@end ignore\n")))
with init values from ALIST (1st optional argument)
"
(let* ((name (symbol->string sym))
- (alist (if (pair? rest) (car rest) '()))
- (type?-name (string->symbol
- (string-append (symbol->string where) "-type?")))
- (doc-name (string->symbol
- (string-append (symbol->string where) "-doc")))
- (type (object-property sym type?-name))
- (typename (verify-type-name where sym type))
- (desc (object-property sym doc-name))
- (init-value (assoc-get sym alist)))
+ (alist (if (pair? rest) (car rest) '()))
+ (type?-name (string->symbol
+ (string-append (symbol->string where) "-type?")))
+ (doc-name (string->symbol
+ (string-append (symbol->string where) "-doc")))
+ (type (object-property sym type?-name))
+ (typename (verify-type-name where sym type))
+ (desc (object-property sym doc-name))
+ (init-value (assoc-get sym alist)))
(if (eq? desc #f)
- (ly:error (_ "cannot find description for property ~S (~S)") sym where))
+ (ly:error (_ "cannot find description for property ~S (~S)") sym where))
(cons
(string-append "@code{" name "} "
- "(" typename ")"
- (if init-value
- (string-append
- ":\n\n"
- (scm->texi init-value)
- "\n\n")
- ""))
+ "(" typename ")"
+ (if init-value
+ (string-append
+ ":\n\n"
+ (scm->texi init-value)
+ "\n\n")
+ ""))
desc)))
-
;; FIXME: how are default/preferred editors specified on
;; different platforms?
(case PLATFORM
- ((windows) "lilypad")
- (else
- "emacs"))))
+ ((windows) "lilypad")
+ (else
+ "emacs"))))
(define editor-command-template-alist
'(("emacs" . "emacsclient --no-wait +%(line)s:%(column)s %(file)s || (emacs +%(line)s:%(column)s %(file)s&)")
(define (get-command-template alist editor)
(define (get-command-template-helper)
(if (null? alist)
- (if (string-match "%\\(file\\)s" editor)
- editor
- (string-append editor " %(file)s"))
- (if (string-match (caar alist) editor)
- (cdar alist)
- (get-command-template (cdr alist) editor))))
+ (if (string-match "%\\(file\\)s" editor)
+ editor
+ (string-append editor " %(file)s"))
+ (if (string-match (caar alist) editor)
+ (cdar alist)
+ (get-command-template (cdr alist) editor))))
(if (string-match "%\\(file\\)s" editor)
editor
(get-command-template-helper)))
(regexp-substitute/global #f re string 'pre sub 'post))
(define (slashify x)
- (if (string-index x #\/)
- x
- (re-sub "\\\\" "/" x)))
+ (if (string-index x #\/)
+ x
+ (re-sub "\\\\" "/" x)))
(define-public (get-editor-command file-name line char column)
(let* ((editor (get-editor))
- (template (get-command-template editor-command-template-alist editor))
- (command
- (re-sub "%\\(file\\)s" (format #f "~S" file-name)
- (re-sub "%\\(line\\)s" (format #f "~a" line)
- (re-sub "%\\(char\\)s" (format #f "~a" char)
- (re-sub
- "%\\(column\\)s" (format #f "~a" column)
- (slashify template)))))))
+ (template (get-command-template editor-command-template-alist editor))
+ (command
+ (re-sub "%\\(file\\)s" (format #f "~S" file-name)
+ (re-sub "%\\(line\\)s" (format #f "~a" line)
+ (re-sub "%\\(char\\)s" (format #f "~a" char)
+ (re-sub
+ "%\\(column\\)s" (format #f "~a" column)
+ (slashify template)))))))
command))
(define-public latin1-coding-vector
#(.notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- %% 0x20
- space exclam quotedbl numbersign dollar percent ampersand quoteright
- parenleft parenright asterisk plus comma hyphen period slash
- zero one two three four five six seven
- eight nine colon semicolon less equal greater question
- %% 0x40
- at A B C D E F G
- H I J K L M N O
- P Q R S T U V W
- X Y Z bracketleft backslash bracketright asciicircum underscore
- %% 0x60
- `quoteleft a b c d e f g
- h i j k l m n o
- p q r s t u v w
- x y z braceleft bar braceright asciitilde .notdef
- %% 0x80
- .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
- dotlessi grave acute circumflex tilde macron breve dotaccent
- dieresis .notdef ring cedilla .notdef hungarumlaut ogonek caron
- %% 0xA0
- space exclamdown cent sterling currency yen brokenbar section
- dieresis copyright ordfeminine guillemotleft logicalnot hyphen registered macron
- degree plusminus twosuperior threesuperior acute mu paragraph periodcentered
- cedilla onesuperior ordmasculine guillemotright onequarter onehalf threequarters questiondown
- %% 0xC0
- Agrave Aacute Acircumflex Atilde Adieresis Aring AE Ccedilla
- Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex Idieresis
- Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis multiply
- Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn germandbls
- %% 0xE0
- agrave aacute acircumflex atilde adieresis aring ae ccedilla
- egrave eacute ecircumflex edieresis igrave iacute icircumflex idieresis
- eth ntilde ograve oacute ocircumflex otilde odieresis divide
- oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis))
+ .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
+ .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
+ .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
+ %% 0x20
+ space exclam quotedbl numbersign dollar percent ampersand quoteright
+ parenleft parenright asterisk plus comma hyphen period slash
+ zero one two three four five six seven
+ eight nine colon semicolon less equal greater question
+ %% 0x40
+ at A B C D E F G
+ H I J K L M N O
+ P Q R S T U V W
+ X Y Z bracketleft backslash bracketright asciicircum underscore
+ %% 0x60
+ `quoteleft a b c d e f g
+ h i j k l m n o
+ p q r s t u v w
+ x y z braceleft bar braceright asciitilde .notdef
+ %% 0x80
+ .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
+ .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef
+ dotlessi grave acute circumflex tilde macron breve dotaccent
+ dieresis .notdef ring cedilla .notdef hungarumlaut ogonek caron
+ %% 0xA0
+ space exclamdown cent sterling currency yen brokenbar section
+ dieresis copyright ordfeminine guillemotleft logicalnot hyphen registered macron
+ degree plusminus twosuperior threesuperior acute mu paragraph periodcentered
+ cedilla onesuperior ordmasculine guillemotright onequarter onehalf threequarters questiondown
+ %% 0xC0
+ Agrave Aacute Acircumflex Atilde Adieresis Aring AE Ccedilla
+ Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex Idieresis
+ Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis multiply
+ Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn germandbls
+ %% 0xE0
+ agrave aacute acircumflex atilde adieresis aring ae ccedilla
+ egrave eacute ecircumflex edieresis igrave iacute icircumflex idieresis
+ eth ntilde ograve oacute ocircumflex otilde odieresis divide
+ oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis))
(define-public (decode-byte-string str)
assuming that @var{str} is byte-coded using latin-1 encoding."
(let* ((len (string-length str))
- (output-vector (make-vector len '.notdef)))
+ (output-vector (make-vector len '.notdef)))
(do
- ((idx 0 (1+ idx)))
- ((>= idx len) output-vector)
+ ((idx 0 (1+ idx)))
+ ((>= idx len) output-vector)
(vector-set! output-vector idx
- (vector-ref latin1-coding-vector
- (char->integer (string-ref str idx)))))))
+ (vector-ref latin1-coding-vector
+ (char->integer (string-ref str idx)))))))
((contents (hash-ref cache-hash-tab filename #f)))
(if (not (string? contents))
- (begin
- (set! contents (ly:gulp-file filename))
- (hash-set! cache-hash-tab filename contents)))
+ (begin
+ (set! contents (ly:gulp-file filename))
+ (hash-set! cache-hash-tab filename contents)))
contents))
(end (offset-add (cons 0 (cdr offset))
(cons (- (/ (car offset) 2)) (* (- (+ thickness (car offset))) dir))))
(stroke (make-line-stencil stroke-thickness (car start) (cdr start) (car end) (cdr end))))
- (ly:stencil-add stencil stroke)))
+ (ly:stencil-add stencil stroke)))
(define (buildflag flag-stencil remain curr-stencil spacing)
"Internal function to recursively create a stencil with @code{remain} flags
(points (if stem-up (list start flag-end
(offset-add flag-end thickness-offset)
(offset-add start thickness-offset))
- (list start
- (offset-add start thickness-offset)
- (offset-add flag-end thickness-offset)
- flag-end)))
+ (list start
+ (offset-add start thickness-offset)
+ (offset-add flag-end thickness-offset)
+ flag-end)))
(stencil (ly:round-filled-polygon points half-stem-thickness))
;; Log for 1/8 is 3, so we need to subtract 3
(flag-stencil (buildflag stencil (- log 3) stencil spacing))
(stroke-style (ly:grob-property grob 'stroke-style)))
- (if (equal? stroke-style "grace")
- (add-stroke-straight flag-stencil grob
- dir log
- stroke-style
- flag-end flag-length
- thickness
- (* half-stem-thickness 2))
- flag-stencil))))
+ (if (equal? stroke-style "grace")
+ (add-stroke-straight flag-stencil grob
+ dir log
+ stroke-style
+ flag-end flag-length
+ thickness
+ (* half-stem-thickness 2))
+ flag-stencil))))
(define-public (modern-straight-flag grob)
"Modern straight flag style (for composers like Stockhausen, Boulez, etc.).
"Load and add a stroke (represented by a glyph in the font) to the given
flag stencil."
(if (not (string? stroke-style))
- stencil
- ;; Otherwise: look up the stroke glyph and combine it with the flag
- (let* ((stem-grob (ly:grob-parent grob X))
- (font-char (string-append "flags." flag-style dir stroke-style))
- (alt-font-char (string-append "flags." dir stroke-style))
- (font (ly:grob-default-font grob))
- (tmpstencil (ly:font-get-glyph font font-char))
- (stroke-stencil (if (ly:stencil-empty? tmpstencil)
- (ly:font-get-glyph font alt-font-char)
- tmpstencil)))
- (if (ly:stencil-empty? stroke-stencil)
- (begin
- (ly:warning (_ "flag stroke `~a' or `~a' not found") font-char alt-font-char)
- stencil)
- (ly:stencil-add stencil stroke-stencil)))))
+ stencil
+ ;; Otherwise: look up the stroke glyph and combine it with the flag
+ (let* ((stem-grob (ly:grob-parent grob X))
+ (font-char (string-append "flags." flag-style dir stroke-style))
+ (alt-font-char (string-append "flags." dir stroke-style))
+ (font (ly:grob-default-font grob))
+ (tmpstencil (ly:font-get-glyph font font-char))
+ (stroke-stencil (if (ly:stencil-empty? tmpstencil)
+ (ly:font-get-glyph font alt-font-char)
+ tmpstencil)))
+ (if (ly:stencil-empty? stroke-stencil)
+ (begin
+ (ly:warning (_ "flag stroke `~a' or `~a' not found") font-char alt-font-char)
+ stencil)
+ (ly:stencil-add stencil stroke-stencil)))))
(define-public (retrieve-glyph-flag flag-style dir dir-modifier grob)
(font-char (string-append "flags." flag-style dir dir-modifier (number->string log)))
(flag (ly:font-get-glyph font font-char)))
(if (ly:stencil-empty? flag)
- (ly:warning "flag ~a not found" font-char))
+ (ly:warning "flag ~a not found" font-char))
flag))
(flag (retrieve-glyph-flag flag-style dir dir-modifier grob))
(stroke-style (ly:grob-property grob 'stroke-style)))
(if (null? stroke-style)
- flag
- (add-stroke-glyph flag grob dir stroke-style flag-style))))
+ flag
+ (add-stroke-glyph flag grob dir stroke-style flag-style))))
(d (ly:grob-property stem-grob 'direction))
(ss (ly:staff-symbol-staff-space stem-grob))
(stem-end (inexact->exact (round (* (index-cell
- (ly:grob-extent stem-grob
- stem-grob
- Y)
- d)
+ (ly:grob-extent stem-grob
+ stem-grob
+ Y)
+ d)
(/ 2 ss)))))
;; For some reason the stem-end is a real instead of an integer...
(dir-modifier (if (ly:position-on-line? stem-grob stem-end) "1" "0"))
(symbol->string flag-style-symbol)
"")))
(cond
- ((equal? flag-style "") (normal-flag grob))
- ((equal? flag-style "mensural") (mensural-flag grob))
- ((equal? flag-style "no-flag") (no-flag grob))
- (else ((glyph-flag flag-style) grob)))))
+ ((equal? flag-style "") (normal-flag grob))
+ ((equal? flag-style "mensural") (mensural-flag grob))
+ ((equal? flag-style "no-flag") (no-flag grob))
+ (else ((glyph-flag flag-style) grob)))))
(make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
(define (make-font-tree-node
- qualifier default)
+ qualifier default)
(make <Font-tree-node>
#:qualifier qualifier
#:default default
(define-method (display (leaf <Font-tree-leaf>) port)
(map (lambda (x) (display x port))
(list
- "#<Font-size-family:\n"
- (slot-ref leaf 'default-size)
- (slot-ref leaf 'size-vector)
- "#>"
- )))
+ "#<Font-size-family:\n"
+ (slot-ref leaf 'default-size)
+ (slot-ref leaf 'size-vector)
+ "#>"
+ )))
(define-method (display (node <Font-tree-node>) port)
(map
(define (make-node fprops size-family)
(if (null? fprops)
- (make-font-tree-leaf (car size-family) (cdr size-family))
- (let* ((qual (next-qualifier default-qualifier-order fprops)))
- (make-font-tree-node qual
- (assoc-get qual fprops)))))
+ (make-font-tree-leaf (car size-family) (cdr size-family))
+ (let* ((qual (next-qualifier default-qualifier-order fprops)))
+ (make-font-tree-node qual
+ (assoc-get qual fprops)))))
(define (next-qualifier order props)
(cond
((null? order) (caar props))
(else
(if (assoc-get (car order) props)
- (car order)
- (next-qualifier (cdr order) props)))))
+ (car order)
+ (next-qualifier (cdr order) props)))))
(let* ((q (font-qualifier node))
- (d (font-default node))
- (v (assoc-get q fprops d))
- (new-fprops (assoc-delete q fprops))
- (child (hashq-ref (slot-ref node 'children)
- v #f)))
+ (d (font-default node))
+ (v (assoc-get q fprops d))
+ (new-fprops (assoc-delete q fprops))
+ (child (hashq-ref (slot-ref node 'children)
+ v #f)))
(if (not child)
- (begin
- (set! child (make-node new-fprops size-family))
- (hashq-set! (slot-ref node 'children) v child)))
+ (begin
+ (set! child (make-node new-fprops size-family))
+ (hashq-set! (slot-ref node 'children) v child)))
(if (pair? new-fprops)
- (add-font child new-fprops size-family))))
+ (add-font child new-fprops size-family))))
(define-method (add-font (node <Font-tree-leaf>) fprops size-family)
(throw "must add to node, not leaf"))
(define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
(let* ((qual (font-qualifier node))
- (def (font-default node))
- (val (chain-assoc-get qual alist-chain def))
- (desired-child (hashq-ref (font-children node) val)))
+ (def (font-default node))
+ (val (chain-assoc-get qual alist-chain def))
+ (desired-child (hashq-ref (font-children node) val)))
(if desired-child
- (g-lookup-font desired-child alist-chain)
- (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
+ (g-lookup-font desired-child alist-chain)
+ (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
(define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
node)
(for-each
(lambda (x)
(add-font node
- (list (cons 'font-encoding (car x))
- (cons 'font-family family))
- (cons (* factor (cadr x))
- (caddr x))))
-
+ (list (cons 'font-encoding (car x))
+ (cons 'font-family family))
+ (cons (* factor (cadr x))
+ (caddr x))))
+
`((fetaText ,(ly:pt 20.0)
- ,(list->vector
- (map (lambda (tup)
- (cons (ly:pt (cdr tup))
- (format #f "~a-~a ~a"
- name
- (car tup)
- (ly:pt (cdr tup)))))
- design-size-alist)))
+ ,(list->vector
+ (map (lambda (tup)
+ (cons (ly:pt (cdr tup))
+ (format #f "~a-~a ~a"
+ name
+ (car tup)
+ (ly:pt (cdr tup)))))
+ design-size-alist)))
(fetaMusic ,(ly:pt 20.0)
- ,(list->vector
- (map (lambda (size-tup)
- (delay (ly:system-font-load
- (format #f "~a-~a" name (car size-tup)))))
- design-size-alist
- )))
+ ,(list->vector
+ (map (lambda (size-tup)
+ (delay (ly:system-font-load
+ (format #f "~a-~a" name (car size-tup)))))
+ design-size-alist
+ )))
(fetaBraces ,(ly:pt 20.0)
- #(,(delay (ly:system-font-load
- (format #f "~a-brace" name)))))
+ #(,(delay (ly:system-font-load
+ (format #f "~a-brace" name)))))
)))
-
+
(define-public (add-pango-fonts node lily-family family factor)
;; Synchronized with the `text-font-size' variable in
;; layout-set-absolute-staff-size-in-module (see paper.scm).
(define (add-node shape series)
(add-font node
- `((font-family . ,lily-family)
- (font-shape . ,shape)
- (font-series . ,series)
- (font-encoding . latin1) ;; ugh.
- )
- `(,text-font-size
- . #(,(cons
- (ly:pt 12)
- (ly:make-pango-description-string
- `(((font-family . ,family)
- (font-series . ,series)
- (font-shape . ,shape)))
- (ly:pt 12)))))))
+ `((font-family . ,lily-family)
+ (font-shape . ,shape)
+ (font-series . ,series)
+ (font-encoding . latin1) ;; ugh.
+ )
+ `(,text-font-size
+ . #(,(cons
+ (ly:pt 12)
+ (ly:make-pango-description-string
+ `(((font-family . ,family)
+ (font-series . ,series)
+ (font-shape . ,shape)))
+ (ly:pt 12)))))))
(add-node 'upright 'normal)
(add-node 'caps 'normal)
(define-public (make-century-schoolbook-tree factor)
(make-pango-font-tree
- "Century Schoolbook L"
- "sans-serif" "monospace" factor))
+ "Century Schoolbook L"
+ "sans-serif" "monospace" factor))
(define-public all-text-font-encodings
'(latin1))
;;; this is still too big a mess.
(use-modules (ice-9 regex)
- (ice-9 string-fun)
- (guile)
- (scm framework-ps)
- (scm paper-system)
- (scm page)
- (scm output-ps)
- (srfi srfi-1)
- (srfi srfi-13)
- (lily))
+ (ice-9 string-fun)
+ (guile)
+ (scm framework-ps)
+ (scm paper-system)
+ (scm page)
+ (scm output-ps)
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (lily))
(define format
ergonomic-simple-format)
alignment."
(define left
(if (pair? stencils)
- (apply min
- (map (lambda (stc)
- (interval-start (ly:stencil-extent stc X)))
- stencils))
- 0.0))
+ (apply min
+ (map (lambda (stc)
+ (interval-start (ly:stencil-extent stc X)))
+ stencils))
+ 0.0))
(map (lambda (stil)
- (ly:make-stencil
- (ly:stencil-expr stil)
- (cons left
- (cdr (ly:stencil-extent stil X)))
- (ly:stencil-extent stil Y)))
+ (ly:make-stencil
+ (ly:stencil-expr stil)
+ (cons left
+ (cdr (ly:stencil-extent stil X)))
+ (ly:stencil-extent stil Y)))
stencils))
(define (dump-stencils-as-EPSes stencils book basename)
(define paper
(ly:paper-book-paper book))
-
+
(define create-aux-files
(ly:get-option 'aux-files))
(define (dump-counted-stencil stencil-count-pair)
"Return EPS filename."
(let* ((stencil (car stencil-count-pair))
- (number (cdr stencil-count-pair))
- (name (format #f "~a-~a" basename number)))
+ (number (cdr stencil-count-pair))
+ (name (format #f "~a-~a" basename number)))
(dump-stencil-as-EPS paper stencil name
- (ly:get-option 'include-eps-fonts))
+ (ly:get-option 'include-eps-fonts))
(string-append name ".eps")))
;; main body
- ;; First, create the output, then if necessary, individual staves and
+ ;; First, create the output, then if necessary, individual staves and
;; finally write some auxiliary files if desired
(dump-infinite-stack-EPS stencils)
(postprocess-output book framework-eps-module
- (format #f "~a.eps" basename) (ly:output-formats))
+ (format #f "~a.eps" basename) (ly:output-formats))
;; individual staves (*-1.eps etc.); only print if more than one stencil
;; Otherwise the .eps and the -1.eps file will be identical and waste space
;; Also always create if aux-files=##t
(if (or create-aux-files (< 1 (length stencils)))
- (let* ((widened-stencils (widen-left-stencil-edges stencils))
- (counted-systems (count-list widened-stencils))
- (eps-files (map dump-counted-stencil counted-systems)))
- (if do-pdf
- ;; par-for-each: a bit faster ...
- (for-each (lambda (y) (postscript->pdf 0 0 y))
- eps-files))))
+ (let* ((widened-stencils (widen-left-stencil-edges stencils))
+ (counted-systems (count-list widened-stencils))
+ (eps-files (map dump-counted-stencil counted-systems)))
+ (if do-pdf
+ ;; par-for-each: a bit faster ...
+ (for-each (lambda (y) (postscript->pdf 0 0 y))
+ eps-files))))
;; Now, write some aux files if requested: .texi, .tex and .count
;; for direct inclusion into latex and texinfo
(if create-aux-files
- (let* ((write-file (lambda (str-port ext)
- (if create-aux-files
- (let* ((name (format #f "~a-systems.~a" basename ext))
- (port (open-output-file name)))
- (ly:message (_ "Writing ~a...") name)
- (display (get-output-string str-port) port)
- (close-output-port port)))))
- (tex-system-port (open-output-string))
- (texi-system-port (open-output-string))
- (count-system-port (open-output-string)))
- (for-each (lambda (c)
- (if (< 0 c)
- (format tex-system-port
- "\\ifx\\betweenLilyPondSystem \\undefined
+ (let* ((write-file (lambda (str-port ext)
+ (if create-aux-files
+ (let* ((name (format #f "~a-systems.~a" basename ext))
+ (port (open-output-file name)))
+ (ly:message (_ "Writing ~a...") name)
+ (display (get-output-string str-port) port)
+ (close-output-port port)))))
+ (tex-system-port (open-output-string))
+ (texi-system-port (open-output-string))
+ (count-system-port (open-output-string)))
+ (for-each (lambda (c)
+ (if (< 0 c)
+ (format tex-system-port
+ "\\ifx\\betweenLilyPondSystem \\undefined
\\linebreak
\\else
\\expandafter\\betweenLilyPondSystem{~a}%
\\fi
" c))
- (format tex-system-port "\\includegraphics{~a-~a}%\n"
- basename (1+ c))
- (format texi-system-port "@image{~a-~a}\n"
- basename (1+ c)))
- (iota (length stencils)))
- (display "@c eof\n" texi-system-port)
- (display "% eof\n" tex-system-port)
- (format count-system-port "~a" (length stencils))
- (write-file texi-system-port "texi")
- (write-file tex-system-port "tex")
- ;; do this as the last action so we know the rest is complete if
- ;; this file is present.
- (write-file count-system-port "count"))))
+ (format tex-system-port "\\includegraphics{~a-~a}%\n"
+ basename (1+ c))
+ (format texi-system-port "@image{~a-~a}\n"
+ basename (1+ c)))
+ (iota (length stencils)))
+ (display "@c eof\n" texi-system-port)
+ (display "% eof\n" tex-system-port)
+ (format count-system-port "~a" (length stencils))
+ (write-file texi-system-port "texi")
+ (write-file tex-system-port "tex")
+ ;; do this as the last action so we know the rest is complete if
+ ;; this file is present.
+ (write-file count-system-port "count"))))
(define-public (output-classic-framework basename book scopes fields)
(output-scopes scopes fields basename)
(if (ly:get-option 'dump-signatures)
(write-system-signatures basename (ly:paper-book-systems book) 1))
(dump-stencils-as-EPSes (map paper-system-stencil
- (ly:paper-book-systems book))
- book
- basename))
+ (ly:paper-book-systems book))
+ book
+ basename))
(define-public (output-framework basename book scopes fields)
(output-scopes scopes fields basename)
(if (ly:get-option 'clip-systems)
(clip-system-EPSes basename book))
(dump-stencils-as-EPSes (map page-stencil
- (ly:paper-book-pages book))
- book
- basename))
+ (ly:paper-book-pages book))
+ book
+ basename))
;; redefine to imports from framework-ps
(define convert-to-pdf
)
(use-modules (ice-9 regex)
- (ice-9 string-fun)
- (guile)
- (srfi srfi-1)
- (ice-9 pretty-print)
- (srfi srfi-13)
- (lily))
+ (ice-9 string-fun)
+ (guile)
+ (srfi srfi-1)
+ (ice-9 pretty-print)
+ (srfi srfi-13)
+ (lily))
(define-public (output-framework channel book scopes fields)
-
+
#t)
(define-public output-classic-framework output-framework)
;;; this is still too big a mess.
(use-modules (ice-9 string-fun)
- (guile)
- (scm page)
- (scm paper-system)
- (srfi srfi-1)
- (srfi srfi-13)
- (scm clip-region)
- (lily))
+ (guile)
+ (scm page)
+ (scm paper-system)
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (scm clip-region)
+ (lily))
(define format ergonomic-simple-format)
(define-public (ps-font-command font)
(let* ((name (ly:font-file-name font))
- (magnify (ly:font-magnification font)))
+ (magnify (ly:font-magnification font)))
(string-append
"magfont"
(ly:string-substitute
(ly:string-substitute
"/" "_"
(ly:string-substitute
- "%" "_" name)))
+ "%" "_" name)))
"m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))))))
(define (ps-define-pango-pf pango-pf font-name scaling)
(string-append
"/lily-output-units "
- (number->string (/ (ly:bp 1))) " def %% millimeter\n"
+ (number->string (/ (ly:bp 1))) " def %% millimeter\n"
(output-entry "staff-line-thickness" 'line-thickness)
(output-entry "line-width" 'line-width)
(output-entry "paper-size" 'papersizename)
- (output-entry "staff-height" 'staff-height) ;junkme.
+ (output-entry "staff-height" 'staff-height) ;junkme.
"/output-scale "
- (number->string (ly:output-def-lookup layout 'output-scale)) " def\n"
+ (number->string (ly:output-def-lookup layout 'output-scale)) " def\n"
(output-entry "page-height" 'paper-height)
(output-entry "page-width" 'paper-width)))
(format #f "%%Page: ~a ~a\n" page-number page-number)
"%%BeginPageSetup\n"
(if landscape?
- "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n"
- "")
+ "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n"
+ "")
"%%EndPageSetup\n"
"\n"
"true setstrokeadjust\n"
(define (supplies-or-needs paper load-fonts?)
(define (extract-names font)
(if (ly:pango-font? font)
- (map car (ly:pango-font-physical-fonts font))
- (list (ly:font-name font))))
+ (map car (ly:pango-font-physical-fonts font))
+ (list (ly:font-name font))))
(let* ((fonts (ly:paper-fonts paper))
- (names (apply append (map extract-names fonts))))
+ (names (apply append (map extract-names fonts))))
(apply string-append
- (map (lambda (f)
- (format #f
- (if load-fonts?
- "%%DocumentSuppliedResources: font ~a\n"
- "%%DocumentNeededResources: font ~a\n")
- f))
- (uniq-list (sort names string<?))))))
+ (map (lambda (f)
+ (format #f
+ (if load-fonts?
+ "%%DocumentSuppliedResources: font ~a\n"
+ "%%DocumentNeededResources: font ~a\n")
+ f))
+ (uniq-list (sort names string<?))))))
(define (eps-header paper bbox load-fonts?)
(string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
- "%%Creator: LilyPond " (lilypond-version) "\n"
- "%%BoundingBox: "
- (string-join (map ly:number->string bbox) " ") "\n"
- "%%Orientation: "
- (if (eq? (ly:output-def-lookup paper 'landscape) #t)
- "Landscape\n"
- "Portrait\n")
- (supplies-or-needs paper load-fonts?)
- "%%EndComments\n"))
+ "%%Creator: LilyPond " (lilypond-version) "\n"
+ "%%BoundingBox: "
+ (string-join (map ly:number->string bbox) " ") "\n"
+ "%%Orientation: "
+ (if (eq? (ly:output-def-lookup paper 'landscape) #t)
+ "Landscape\n"
+ "Portrait\n")
+ (supplies-or-needs paper load-fonts?)
+ "%%EndComments\n"))
(define (ps-document-media paper)
(let* ((w (/ (*
- (ly:output-def-lookup paper 'output-scale)
- (ly:output-def-lookup paper 'paper-width)) (ly:bp 1)))
- (h (/ (*
- (ly:output-def-lookup paper 'paper-height)
- (ly:output-def-lookup paper 'output-scale))
- (ly:bp 1)))
- (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)))
+ (ly:output-def-lookup paper 'output-scale)
+ (ly:output-def-lookup paper 'paper-width)) (ly:bp 1)))
+ (h (/ (*
+ (ly:output-def-lookup paper 'paper-height)
+ (ly:output-def-lookup paper 'output-scale))
+ (ly:bp 1)))
+ (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)))
(ly:format "%%DocumentMedia: ~a ~2f ~2f ~a ~a ~a\n"
- (ly:output-def-lookup paper 'papersizename)
- (if landscape? h w)
- (if landscape? w h)
- 80 ;; weight
- "()" ;; color
- "()" ;; type
- )))
+ (ly:output-def-lookup paper 'papersizename)
+ (if landscape? h w)
+ (if landscape? w h)
+ 80 ;; weight
+ "()" ;; color
+ "()" ;; type
+ )))
(define (file-header paper page-count load-fonts?)
(string-append "%!PS-Adobe-3.0\n"
- "%%Creator: LilyPond " (lilypond-version) "\n"
- "%%Pages: " (number->string page-count) "\n"
- "%%PageOrder: Ascend\n"
- "%%Orientation: "
- (if (eq? (ly:output-def-lookup paper 'landscape) #t)
- "Landscape\n"
- "Portrait\n")
- (ps-document-media paper)
- (supplies-or-needs paper load-fonts?)
- "%%EndComments\n"))
+ "%%Creator: LilyPond " (lilypond-version) "\n"
+ "%%Pages: " (number->string page-count) "\n"
+ "%%PageOrder: Ascend\n"
+ "%%Orientation: "
+ (if (eq? (ly:output-def-lookup paper 'landscape) #t)
+ "Landscape\n"
+ "Portrait\n")
+ (ps-document-media paper)
+ (supplies-or-needs paper load-fonts?)
+ "%%EndComments\n"))
(define (procset file-name)
(format #f
- "%%BeginResource: procset (~a) 1 0
+ "%%BeginResource: procset (~a) 1 0
~a
%%EndResource
"
- file-name (cached-file-contents file-name)))
+ file-name (cached-file-contents file-name)))
(define (embed-document file-name)
(format #f "%%BeginDocument: ~a
~a
%%EndDocument
"
- file-name (cached-file-contents file-name)))
+ file-name (cached-file-contents file-name)))
(define (setup-variables paper)
(string-append
(define-public (ps-embed-cff body font-set-name version)
(let* ((binary-data
- (string-append
- (format #f "/~a ~s StartData " font-set-name (string-length body))
- body))
- (header
- (format #f
- "%%BeginResource: font ~a
+ (string-append
+ (format #f "/~a ~s StartData " font-set-name (string-length body))
+ body))
+ (header
+ (format #f
+ "%%BeginResource: font ~a
%!PS-Adobe-3.0 Resource-FontSet
%%DocumentNeededResources: ProcSet (FontSetInit)
%%Title: (FontSet/~a)
/FontSetInit /ProcSet findresource begin
%%BeginData: ~s Binary Bytes
"
- font-set-name font-set-name version font-set-name
- (string-length binary-data)))
- (footer "\n%%EndData
+ font-set-name font-set-name version font-set-name
+ (string-length binary-data)))
+ (footer "\n%%EndData
%%EndResource
%%EndResource\n"))
(string-append header
- binary-data
- footer)))
+ binary-data
+ footer)))
(define (write-preamble paper load-fonts? port)
(define (internal-font? file-name)
(or (string-startswith file-name "Emmentaler")
- (string-startswith file-name "emmentaler")
- ))
+ (string-startswith file-name "emmentaler")
+ ))
(define (load-font-via-GS font-name-filename)
(define (ps-load-file file-name)
(if (string? file-name)
- (if (string-contains file-name (ly:get-option 'datadir))
- (begin
- (set! file-name (ly:string-substitute (ly:get-option 'datadir)
- "" file-name))
- (format #f
- "lilypond-datadir (~a) concatstrings (r) file .loadfont\n"
- file-name))
- (format #f "(~a) (r) file .loadfont\n" file-name))
- (format #f "% cannot find font file: ~a\n" file-name)))
+ (if (string-contains file-name (ly:get-option 'datadir))
+ (begin
+ (set! file-name (ly:string-substitute (ly:get-option 'datadir)
+ "" file-name))
+ (format #f
+ "lilypond-datadir (~a) concatstrings (r) file .loadfont\n"
+ file-name))
+ (format #f "(~a) (r) file .loadfont\n" file-name))
+ (format #f "% cannot find font file: ~a\n" file-name)))
(let* ((font (car font-name-filename))
- (name (cadr font-name-filename))
- (file-name (caddr font-name-filename))
- (bare-file-name (ly:find-file file-name)))
+ (name (cadr font-name-filename))
+ (file-name (caddr font-name-filename))
+ (bare-file-name (ly:find-file file-name)))
(cons name
- (if (mac-font? bare-file-name)
- (handle-mac-font name bare-file-name)
- (cond
- ((internal-font? file-name)
- (ps-load-file (ly:find-file
- (format #f "~a.otf" file-name))))
- ((string? bare-file-name)
- (ps-load-file file-name))
- (else
- (ly:warning (_ "cannot embed ~S=~S") name file-name)
- ""))))))
+ (if (mac-font? bare-file-name)
+ (handle-mac-font name bare-file-name)
+ (cond
+ ((internal-font? file-name)
+ (ps-load-file (ly:find-file
+ (format #f "~a.otf" file-name))))
+ ((string? bare-file-name)
+ (ps-load-file file-name))
+ (else
+ (ly:warning (_ "cannot embed ~S=~S") name file-name)
+ ""))))))
(define (dir-join a b)
(if (equal? a "")
- b
- (string-append a "/" b)))
+ b
+ (string-append a "/" b)))
(define (dir-listing dir-name)
(define (dir-helper dir lst)
(let ((e (readdir dir)))
- (if (eof-object? e)
- lst
- (dir-helper dir (cons e lst)))))
+ (if (eof-object? e)
+ lst
+ (dir-helper dir (cons e lst)))))
(reverse (dir-helper (opendir dir-name) '())))
(define (handle-mac-font name file-name)
(let* ((dir-name (tmpnam))
- (files '())
- (status 0)
- (embed #f)
- (cwd (getcwd)))
+ (files '())
+ (status 0)
+ (embed #f)
+ (cwd (getcwd)))
(mkdir dir-name #o700)
(chdir dir-name)
(set! status (ly:system (list "fondu" "-force" file-name)))
(set! files (dir-listing dir-name))
(for-each
(lambda (f)
- (let* ((full-name (dir-join dir-name f)))
- (if (and (not embed)
- (equal? 'regular (stat:type (stat full-name)))
- (equal? name (ly:ttf-ps-name full-name)))
- (set! embed (font-file-as-ps-string name full-name 0)))
- (if (or (equal? "." f)
- (equal? ".." f))
- #t
- (delete-file full-name))))
+ (let* ((full-name (dir-join dir-name f)))
+ (if (and (not embed)
+ (equal? 'regular (stat:type (stat full-name)))
+ (equal? name (ly:ttf-ps-name full-name)))
+ (set! embed (font-file-as-ps-string name full-name 0)))
+ (if (or (equal? "." f)
+ (equal? ".." f))
+ #t
+ (delete-file full-name))))
files)
(rmdir dir-name)
(if (not embed)
- (begin
- (set! embed "% failed\n")
- (ly:warning (_ "cannot extract file matching ~a from ~a")
- name file-name)))
+ (begin
+ (set! embed "% failed\n")
+ (ly:warning (_ "cannot extract file matching ~a from ~a")
+ name file-name)))
embed))
(define (font-file-as-ps-string name file-name font-index)
(let* ((downcase-file-name (string-downcase file-name)))
(cond
((and file-name (string-endswith downcase-file-name ".pfa"))
- (embed-document file-name))
+ (embed-document file-name))
((and file-name (string-endswith downcase-file-name ".pfb"))
- (ly:pfb->pfa file-name))
+ (ly:pfb->pfa file-name))
((and file-name (string-endswith downcase-file-name ".ttf"))
- (ly:ttf->pfa file-name))
+ (ly:ttf->pfa file-name))
((and file-name (string-endswith downcase-file-name ".ttc"))
- (ly:ttf->pfa file-name font-index))
+ (ly:ttf->pfa file-name font-index))
((and file-name (string-endswith downcase-file-name ".otf"))
- (ps-embed-cff (ly:otf->cff file-name) name 0))
+ (ps-embed-cff (ly:otf->cff file-name) name 0))
(else
- (ly:warning (_ "do not know how to embed ~S=~S") name file-name)
- ""))))
+ (ly:warning (_ "do not know how to embed ~S=~S") name file-name)
+ ""))))
(define (mac-font? bare-file-name)
(and (eq? PLATFORM 'darwin)
- bare-file-name
- (or (string-endswith bare-file-name ".dfont")
- (= (stat:size (stat bare-file-name)) 0))))
+ bare-file-name
+ (or (string-endswith bare-file-name ".dfont")
+ (= (stat:size (stat bare-file-name)) 0))))
(define (load-font font-psname-filename-fontindex)
(let* ((font (list-ref font-psname-filename-fontindex 0))
- (name (list-ref font-psname-filename-fontindex 1))
- (file-name (list-ref font-psname-filename-fontindex 2))
- (font-index (list-ref font-psname-filename-fontindex 3))
- (bare-file-name (ly:find-file file-name)))
+ (name (list-ref font-psname-filename-fontindex 1))
+ (file-name (list-ref font-psname-filename-fontindex 2))
+ (font-index (list-ref font-psname-filename-fontindex 3))
+ (bare-file-name (ly:find-file file-name)))
(cons name
- (cond ((mac-font? bare-file-name)
- (handle-mac-font name bare-file-name))
- ((and font (cff-font? font))
- (ps-embed-cff (ly:otf-font-table-data font "CFF ")
- name
- 0))
- (bare-file-name (font-file-as-ps-string
- name bare-file-name font-index))
- (else
- (ly:warning (_ "do not know how to embed font ~s ~s ~s")
- name file-name font))))))
+ (cond ((mac-font? bare-file-name)
+ (handle-mac-font name bare-file-name))
+ ((and font (cff-font? font))
+ (ps-embed-cff (ly:otf-font-table-data font "CFF ")
+ name
+ 0))
+ (bare-file-name (font-file-as-ps-string
+ name bare-file-name font-index))
+ (else
+ (ly:warning (_ "do not know how to embed font ~s ~s ~s")
+ name file-name font))))))
(define (load-fonts paper)
(let* ((fonts (ly:paper-fonts paper))
- ;; todo - doc format of list.
- (all-font-names
- (map
- (lambda (font)
- (cond ((string? (ly:font-file-name font))
- (list (list font
- (ly:font-name font)
- (ly:font-file-name font)
- #f)))
- ((ly:pango-font? font)
- (map (lambda (psname-filename-fontindex)
- (list #f
- (list-ref psname-filename-fontindex 0)
- (list-ref psname-filename-fontindex 1)
- (list-ref psname-filename-fontindex 2)))
- (ly:pango-font-physical-fonts font)))
- (else
- (ly:font-sub-fonts font))))
- fonts))
- (font-names (uniq-list
- (sort (apply append all-font-names)
- (lambda (x y) (string<? (cadr x) (cadr y))))))
-
- ;; slightly spaghetti-ish: deciding what to load where
- ;; is smeared out.
- (font-loader
- (lambda (name)
- (cond ((ly:get-option 'gs-load-fonts)
- (load-font-via-GS name))
- ((ly:get-option 'gs-load-lily-fonts)
- (if (or (string-contains (caddr name)
- (ly:get-option 'datadir))
- (internal-font? (caddr name)))
- (load-font-via-GS name)
- (load-font name)))
- (else
- (load-font name)))))
- (pfas (map font-loader font-names)))
+ ;; todo - doc format of list.
+ (all-font-names
+ (map
+ (lambda (font)
+ (cond ((string? (ly:font-file-name font))
+ (list (list font
+ (ly:font-name font)
+ (ly:font-file-name font)
+ #f)))
+ ((ly:pango-font? font)
+ (map (lambda (psname-filename-fontindex)
+ (list #f
+ (list-ref psname-filename-fontindex 0)
+ (list-ref psname-filename-fontindex 1)
+ (list-ref psname-filename-fontindex 2)))
+ (ly:pango-font-physical-fonts font)))
+ (else
+ (ly:font-sub-fonts font))))
+ fonts))
+ (font-names (uniq-list
+ (sort (apply append all-font-names)
+ (lambda (x y) (string<? (cadr x) (cadr y))))))
+
+ ;; slightly spaghetti-ish: deciding what to load where
+ ;; is smeared out.
+ (font-loader
+ (lambda (name)
+ (cond ((ly:get-option 'gs-load-fonts)
+ (load-font-via-GS name))
+ ((ly:get-option 'gs-load-lily-fonts)
+ (if (or (string-contains (caddr name)
+ (ly:get-option 'datadir))
+ (internal-font? (caddr name)))
+ (load-font-via-GS name)
+ (load-font name)))
+ (else
+ (load-font name)))))
+ (pfas (map font-loader font-names)))
pfas))
(ly:get-option 'datadir))
(if load-fonts?
(for-each (lambda (f)
- (format port "\n%%BeginFont: ~a\n" (car f))
- (display (cdr f) port)
- (display "%%EndFont\n" port))
- (load-fonts paper)))
+ (format port "\n%%BeginFont: ~a\n" (car f))
+ (display (cdr f) port)
+ (display "%%EndFont\n" port))
+ (load-fonts paper)))
(display (setup-variables paper) port)
;; adobe note 5002: should initialize variables before loading routines.
(display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port))
(define (ps-quote str)
- (fold
- (lambda (replacement-list result)
- (string-join
- (string-split
- result
- (car replacement-list))
- (cadr replacement-list)))
- str
- '((#\\ "\\\\") (#\( "\\(") (#\) "\\)"))))
+ (fold
+ (lambda (replacement-list result)
+ (string-join
+ (string-split
+ result
+ (car replacement-list))
+ (cadr replacement-list)))
+ str
+ '((#\\ "\\\\") (#\( "\\(") (#\) "\\)"))))
;;; Create DOCINFO pdfmark containing metadata
;;; header fields with pdf prefix override those without the prefix
(ps-quote (ly:encode-string-for-pdf val)))
(define (metadata-lookup-output overridevar fallbackvar field)
(let* ((overrideval (ly:modules-lookup (list header) overridevar))
- (fallbackval (ly:modules-lookup (list header) fallbackvar))
- (val (if overrideval overrideval fallbackval)))
+ (fallbackval (ly:modules-lookup (list header) fallbackvar))
+ (val (if overrideval overrideval fallbackval)))
(if val
- (format port "/~a (~a)\n" field (metadata-encode (markup->string val (list header)))))))
+ (format port "/~a (~a)\n" field (metadata-encode (markup->string val (list header)))))))
(display "[ " port)
(metadata-lookup-output 'pdfcomposer 'composer "Author")
(format port "/Creator (LilyPond ~a)\n" (lilypond-version))
(define-public (output-framework basename book scopes fields)
(let* ((filename (format #f "~a.ps" basename))
- (outputter (ly:make-paper-outputter
- ;; FIXME: better wrap open/open-file,
- ;; content-mangling is always bad.
- ;; MINGW hack: need to have "b"inary for embedding CFFs
- (open-file filename "wb")
- 'ps))
- (paper (ly:paper-book-paper book))
- (header (ly:paper-book-header book))
- (systems (ly:paper-book-systems book))
- (page-stencils (map page-stencil (ly:paper-book-pages book)))
- (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
- (page-number (1- (ly:output-def-lookup paper 'first-page-number)))
- (page-count (length page-stencils))
- (port (ly:outputter-port outputter)))
+ (outputter (ly:make-paper-outputter
+ ;; FIXME: better wrap open/open-file,
+ ;; content-mangling is always bad.
+ ;; MINGW hack: need to have "b"inary for embedding CFFs
+ (open-file filename "wb")
+ 'ps))
+ (paper (ly:paper-book-paper book))
+ (header (ly:paper-book-header book))
+ (systems (ly:paper-book-systems book))
+ (page-stencils (map page-stencil (ly:paper-book-pages book)))
+ (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
+ (page-number (1- (ly:output-def-lookup paper 'first-page-number)))
+ (page-count (length page-stencils))
+ (port (ly:outputter-port outputter)))
(if (ly:get-option 'clip-systems)
- (clip-system-EPSes basename book))
+ (clip-system-EPSes basename book))
(if (ly:get-option 'dump-signatures)
- (write-system-signatures basename (ly:paper-book-systems book) 1))
+ (write-system-signatures basename (ly:paper-book-systems book) 1))
(output-scopes scopes fields basename)
(display (file-header paper page-count #t) port)
;; don't do BeginDefaults PageMedia: A4
;; not necessary and wrong
(write-preamble paper #t port)
(if (module? header)
- (handle-metadata header port))
+ (handle-metadata header port))
(for-each
(lambda (page)
(set! page-number (1+ page-number))
(display "%%Trailer\n%%EOF\n" port)
(ly:outputter-close outputter)
(postprocess-output book framework-ps-module filename
- (ly:output-formats))))
+ (ly:output-formats))))
(define-public (dump-stencil-as-EPS paper dump-me filename
- load-fonts)
+ load-fonts)
(let* ((xext (ly:stencil-extent dump-me X))
- (yext (ly:stencil-extent dump-me Y))
- (padding (ly:get-option 'eps-box-padding))
- (left-overshoot (if (number? padding)
- (* -1 padding (ly:output-def-lookup paper 'mm))
- #f))
- (bbox
- (map
- (lambda (x)
- (if (or (nan? x) (inf? x)
- ;; FIXME: huh?
- (equal? (format #f "~S" x) "+#.#")
- (equal? (format #f "~S" x) "-#.#"))
- 0.0 x))
-
- ;; the left-overshoot is to make sure that
- ;; bar numbers stick out of margin uniformly.
- ;;
- (list
- (if (number? left-overshoot)
- (min left-overshoot (car xext))
- (car xext))
- (car yext) (cdr xext) (cdr yext)))))
+ (yext (ly:stencil-extent dump-me Y))
+ (padding (ly:get-option 'eps-box-padding))
+ (left-overshoot (if (number? padding)
+ (* -1 padding (ly:output-def-lookup paper 'mm))
+ #f))
+ (bbox
+ (map
+ (lambda (x)
+ (if (or (nan? x) (inf? x)
+ ;; FIXME: huh?
+ (equal? (format #f "~S" x) "+#.#")
+ (equal? (format #f "~S" x) "-#.#"))
+ 0.0 x))
+
+ ;; the left-overshoot is to make sure that
+ ;; bar numbers stick out of margin uniformly.
+ ;;
+ (list
+ (if (number? left-overshoot)
+ (min left-overshoot (car xext))
+ (car xext))
+ (car yext) (cdr xext) (cdr yext)))))
(dump-stencil-as-EPS-with-bbox paper dump-me filename load-fonts bbox)))
(define-public (dump-stencil-as-EPS-with-bbox paper dump-me filename
- load-fonts
- bbox)
+ load-fonts
+ bbox)
"Create an EPS file from stencil @var{dump-me} to @var{filename}.
@var{bbox} has format @code{(left-x, lower-y, right-x, upper-y)}. If
@var{load-fonts} set, include fonts inline."
(define (to-rounded-bp-box box)
"Convert box to 1/72 inch with rounding to enlarge the box."
(let* ((scale (ly:output-def-lookup paper 'output-scale))
- (strip-non-number (lambda (x)
- (if (or (nan? x)
- (inf? x))
- 0.0
- x)))
- (directed-round (lambda (x rounder)
- (inexact->exact
- (rounder (/ (* (strip-non-number x) scale)
- (ly:bp 1)))))))
+ (strip-non-number (lambda (x)
+ (if (or (nan? x)
+ (inf? x))
+ 0.0
+ x)))
+ (directed-round (lambda (x rounder)
+ (inexact->exact
+ (rounder (/ (* (strip-non-number x) scale)
+ (ly:bp 1)))))))
(list (directed-round (car box) floor)
- (directed-round (cadr box) floor)
- (directed-round (max (1+ (car box)) (caddr box)) ceiling)
- (directed-round (max (1+ (cadr box)) (cadddr box)) ceiling))))
+ (directed-round (cadr box) floor)
+ (directed-round (max (1+ (car box)) (caddr box)) ceiling)
+ (directed-round (max (1+ (cadr box)) (cadddr box)) ceiling))))
(let* ((outputter (ly:make-paper-outputter
- ;; FIXME: better wrap open/open-file,
- ;; content-mangling is always bad.
- ;; MINGW hack: need to have "b"inary for embedding CFFs
- (open-file (format #f "~a.eps" filename) "wb")
- 'ps))
- (port (ly:outputter-port outputter))
- (rounded-bbox (to-rounded-bp-box bbox))
- (port (ly:outputter-port outputter))
- (header (eps-header paper rounded-bbox load-fonts)))
+ ;; FIXME: better wrap open/open-file,
+ ;; content-mangling is always bad.
+ ;; MINGW hack: need to have "b"inary for embedding CFFs
+ (open-file (format #f "~a.eps" filename) "wb")
+ 'ps))
+ (port (ly:outputter-port outputter))
+ (rounded-bbox (to-rounded-bp-box bbox))
+ (port (ly:outputter-port outputter))
+ (header (eps-header paper rounded-bbox load-fonts)))
(display header port)
(write-preamble paper load-fonts port)
(display "gsave set-ps-scale-to-lily-scale\n" port)
(define (clip-systems-to-region basename paper systems region do-pdf do-png)
(let* ((extents-system-pairs
- (filtered-map (lambda (paper-system)
- (let* ((x-ext (system-clipped-x-extent
- (paper-system-system-grob paper-system)
- region)))
- (if x-ext
- (cons x-ext paper-system)
- #f)))
- systems))
- (count 0))
+ (filtered-map (lambda (paper-system)
+ (let* ((x-ext (system-clipped-x-extent
+ (paper-system-system-grob paper-system)
+ region)))
+ (if x-ext
+ (cons x-ext paper-system)
+ #f)))
+ systems))
+ (count 0))
(for-each
(lambda (ext-system-pair)
(let* ((xext (car ext-system-pair))
- (paper-system (cdr ext-system-pair))
- (yext (paper-system-extent paper-system Y))
- (bbox (list (car xext) (car yext)
- (cdr xext) (cdr yext)))
- (filename (if (< 0 count)
- (format #f "~a-~a" basename count)
- basename)))
- (set! count (1+ count))
- (dump-stencil-as-EPS-with-bbox paper
- (paper-system-stencil paper-system)
- filename
- (ly:get-option 'include-eps-fonts)
- bbox)
- (if do-pdf
- (postscript->pdf 0 0 (format #f "~a.eps" filename)))
- (if do-png
- (postscript->png (ly:get-option 'resolution) 0 0
- (format #f "~a.eps" filename)))))
+ (paper-system (cdr ext-system-pair))
+ (yext (paper-system-extent paper-system Y))
+ (bbox (list (car xext) (car yext)
+ (cdr xext) (cdr yext)))
+ (filename (if (< 0 count)
+ (format #f "~a-~a" basename count)
+ basename)))
+ (set! count (1+ count))
+ (dump-stencil-as-EPS-with-bbox paper
+ (paper-system-stencil paper-system)
+ filename
+ (ly:get-option 'include-eps-fonts)
+ bbox)
+ (if do-pdf
+ (postscript->pdf 0 0 (format #f "~a.eps" filename)))
+ (if do-png
+ (postscript->png (ly:get-option 'resolution) 0 0
+ (format #f "~a.eps" filename)))))
extents-system-pairs)))
(define-public (clip-system-EPSes basename paper-book)
(define (clip-score-systems basename systems)
(let* ((layout (ly:grob-layout (paper-system-system-grob (car systems))))
- (regions (ly:output-def-lookup layout 'clip-regions)))
+ (regions (ly:output-def-lookup layout 'clip-regions)))
(for-each
(lambda (region)
- (clip-systems-to-region
- (format #f "~a-from-~a-to-~a-clip"
- basename
- (rhythmic-location->file-string (car region))
- (rhythmic-location->file-string (cdr region)))
- layout systems region
- do-pdf do-png))
+ (clip-systems-to-region
+ (format #f "~a-from-~a-to-~a-clip"
+ basename
+ (rhythmic-location->file-string (car region))
+ (rhythmic-location->file-string (cdr region)))
+ layout systems region
+ do-pdf do-png))
regions)))
;; partition in system lists sharing their layout blocks
(let* ((systems (ly:paper-book-systems paper-book))
- (count 0)
- (score-system-list '()))
+ (count 0)
+ (score-system-list '()))
(fold
(lambda (system last-system)
(if (not (and last-system
- (equal? (paper-system-layout last-system)
- (paper-system-layout system))))
- (set! score-system-list (cons '() score-system-list)))
+ (equal? (paper-system-layout last-system)
+ (paper-system-layout system))))
+ (set! score-system-list (cons '() score-system-list)))
(if (paper-system-layout system)
- (set-car! score-system-list (cons system (car score-system-list))))
+ (set-car! score-system-list (cons system (car score-system-list))))
;; pass value.
system)
#f
systems)
(for-each (lambda (system-list)
- ;; filter out headers and top-level markup
- (if (pair? system-list)
- (clip-score-systems
- (if (> count 0)
- (format #f "~a-~a" basename count)
- basename)
- system-list)))
- score-system-list)))
+ ;; filter out headers and top-level markup
+ (if (pair? system-list)
+ (clip-score-systems
+ (if (> count 0)
+ (format #f "~a-~a" basename count)
+ basename)
+ system-list)))
+ score-system-list)))
(define-public (output-preview-framework basename book scopes fields)
(let* ((paper (ly:paper-book-paper book))
- (systems (relevant-book-systems book))
- (to-dump-systems (relevant-dump-systems systems)))
+ (systems (relevant-book-systems book))
+ (to-dump-systems (relevant-dump-systems systems)))
(dump-stencil-as-EPS paper
- (stack-stencils Y DOWN 0.0
- (map paper-system-stencil
- (reverse to-dump-systems)))
- (format #f "~a.preview" basename)
- #t)
+ (stack-stencils Y DOWN 0.0
+ (map paper-system-stencil
+ (reverse to-dump-systems)))
+ (format #f "~a.preview" basename)
+ #t)
(postprocess-output book framework-ps-module
- (format #f "~a.preview.eps" basename)
- (cons "png" (ly:output-formats)))))
+ (format #f "~a.preview.eps" basename)
+ (cons "png" (ly:output-formats)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (output-width-height defs)
(let* ((landscape (ly:output-def-lookup defs 'landscape))
- (output-scale (ly:output-def-lookup defs 'output-scale))
- (convert (lambda (x)
- (* x output-scale (/ (ly:bp 1)))))
- (paper-width (convert (ly:output-def-lookup defs 'paper-width)))
- (paper-height (convert (ly:output-def-lookup defs 'paper-height)))
- (w (if landscape paper-height paper-width))
- (h (if landscape paper-width paper-height)))
+ (output-scale (ly:output-def-lookup defs 'output-scale))
+ (convert (lambda (x)
+ (* x output-scale (/ (ly:bp 1)))))
+ (paper-width (convert (ly:output-def-lookup defs 'paper-width)))
+ (paper-height (convert (ly:output-def-lookup defs 'paper-height)))
+ (w (if landscape paper-height paper-width))
+ (h (if landscape paper-width paper-height)))
(cons w h)))
(define (output-resolution defs)
(let ((defs-resolution (ly:output-def-lookup defs 'pngresolution)))
(if (number? defs-resolution)
- defs-resolution
- (ly:get-option 'resolution))))
+ defs-resolution
+ (ly:get-option 'resolution))))
(define (output-filename name)
(if (equal? (basename name ".ps") "-")
(define-public (convert-to-pdf book name)
(let* ((defs (ly:paper-book-paper book))
- (width-height (output-width-height defs))
- (width (car width-height))
- (height (cdr width-height))
- (filename (output-filename name)))
+ (width-height (output-width-height defs))
+ (width (car width-height))
+ (height (cdr width-height))
+ (filename (output-filename name)))
(postscript->pdf width height filename)))
(define-public (convert-to-png book name)
(let* ((defs (ly:paper-book-paper book))
- (resolution (output-resolution defs))
- (width-height (output-width-height defs))
- (width (car width-height))
- (height (cdr width-height))
- (filename (output-filename name)))
+ (resolution (output-resolution defs))
+ (width-height (output-width-height defs))
+ (width (car width-height))
+ (height (cdr width-height))
+ (filename (output-filename name)))
(postscript->png resolution width height filename)))
(define-public (convert-to-ps book name)
(define-module (scm framework-scm))
(use-modules
- (ice-9 regex)
- (ice-9 string-fun)
- (guile)
- (srfi srfi-1)
- (ice-9 pretty-print)
- (srfi srfi-13)
- (scm page)
- (lily))
+ (ice-9 regex)
+ (ice-9 string-fun)
+ (guile)
+ (srfi srfi-1)
+ (ice-9 pretty-print)
+ (srfi srfi-13)
+ (scm page)
+ (lily))
(define format ergonomic-simple-format)
(define-public (output-framework basename book scopes fields)
(let* ((file (open-output-file (format #f "~a.scm" basename))))
-
+
(display ";;Creator: LilyPond\n" file)
(display ";; raw SCM output\n" file)
-
+
(for-each
- (lambda (page)
- (display ";;;;;;;;;;;;;;;;;;;;;;;;;;\n;;;PAGE\n" file)
- ;; The following two lines are alternates
- ;;(pretty-print (ly:stencil-expr page) file)
- (write (ly:stencil-expr page) file)
- )
- (map page-stencil (ly:paper-book-pages book)))))
+ (lambda (page)
+ (display ";;;;;;;;;;;;;;;;;;;;;;;;;;\n;;;PAGE\n" file)
+ ;; The following two lines are alternates
+ ;;(pretty-print (ly:stencil-expr page) file)
+ (write (ly:stencil-expr page) file)
+ )
+ (map page-stencil (ly:paper-book-pages book)))))
(define-public output-classic-framework output-framework)
)
(use-modules (ice-9 regex)
- (ice-9 string-fun)
- (scm paper-system)
- (ice-9 format)
- (guile)
- (srfi srfi-1)
- (ice-9 pretty-print)
- (srfi srfi-13)
- (lily))
+ (ice-9 string-fun)
+ (scm paper-system)
+ (ice-9 format)
+ (guile)
+ (srfi srfi-1)
+ (ice-9 pretty-print)
+ (srfi srfi-13)
+ (lily))
(define (get-page-dimensions paper)
(let* ((landscape (ly:output-def-lookup paper 'landscape))
- (output-scale (ly:output-def-lookup paper 'output-scale))
- (paper-width (ly:output-def-lookup paper 'paper-width))
- (paper-height (ly:output-def-lookup paper 'paper-height))
- (indent (ly:output-def-lookup paper 'indent))
- (line-width (ly:output-def-lookup paper 'line-width))
- (plain-left-margin (ly:output-def-lookup paper 'left-margin))
- (top-margin (ly:output-def-lookup paper 'top-margin))
- (w (if landscape paper-height paper-width))
- (h (if landscape paper-width paper-height))
- (left-margin (if (null? plain-left-margin)
- (/ (- w line-width) 2)
- plain-left-margin))
-;; (list w h left-margin top-margin indent line-width)))
-;; (convert (lambda (x) (* x output-scale (/ (ly:bp 1))))))
- (unit-length (ly:output-def-lookup paper 'output-scale))
- (convert (lambda (x) (* x lily-unit->mm-factor unit-length))))
+ (output-scale (ly:output-def-lookup paper 'output-scale))
+ (paper-width (ly:output-def-lookup paper 'paper-width))
+ (paper-height (ly:output-def-lookup paper 'paper-height))
+ (indent (ly:output-def-lookup paper 'indent))
+ (line-width (ly:output-def-lookup paper 'line-width))
+ (plain-left-margin (ly:output-def-lookup paper 'left-margin))
+ (top-margin (ly:output-def-lookup paper 'top-margin))
+ (w (if landscape paper-height paper-width))
+ (h (if landscape paper-width paper-height))
+ (left-margin (if (null? plain-left-margin)
+ (/ (- w line-width) 2)
+ plain-left-margin))
+ ;; (list w h left-margin top-margin indent line-width)))
+ ;; (convert (lambda (x) (* x output-scale (/ (ly:bp 1))))))
+ (unit-length (ly:output-def-lookup paper 'output-scale))
+ (convert (lambda (x) (* x lily-unit->mm-factor unit-length))))
(map convert (list w h left-margin top-margin indent line-width))))
(define-public (output-framework channel book scopes fields)
(let* ((ctor-arg (if (string? channel)
- (open-output-file (format #f "~a.socket" channel))
- channel))
- (outputter (ly:make-paper-outputter
- ctor-arg
- 'socket))
- (systems (ly:paper-book-systems book))
- (paper (ly:paper-book-paper book))
- (pages (ly:paper-book-pages book)))
+ (open-output-file (format #f "~a.socket" channel))
+ channel))
+ (outputter (ly:make-paper-outputter
+ ctor-arg
+ 'socket))
+ (systems (ly:paper-book-systems book))
+ (paper (ly:paper-book-paper book))
+ (pages (ly:paper-book-pages book)))
(for-each (lambda (x)
- (let* ((system-stencil (paper-system-stencil x))
- (x-extent (ly:stencil-extent system-stencil X))
- (y-extent (ly:stencil-extent system-stencil Y)))
- (display (ly:format "system ~4l ~4l ~4l ~4l\n"
- (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg)
- (ly:outputter-dump-stencil outputter system-stencil)))
- systems)))
+ (let* ((system-stencil (paper-system-stencil x))
+ (x-extent (ly:stencil-extent system-stencil X))
+ (y-extent (ly:stencil-extent system-stencil Y)))
+ (display (ly:format "system ~4l ~4l ~4l ~4l\n"
+ (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg)
+ (ly:outputter-dump-stencil outputter system-stencil)))
+ systems)))
(define-public (output-classic-framework channel book scopes fields)
(let* ((ctor-arg (if (string? channel)
- (open-output-file (format #f "~a.socket" channel))
- channel))
- (outputter (ly:make-paper-outputter
- ctor-arg
- 'socket))
- (systems (ly:paper-book-systems book))
- (paper (ly:paper-book-paper book)))
+ (open-output-file (format #f "~a.socket" channel))
+ channel))
+ (outputter (ly:make-paper-outputter
+ ctor-arg
+ 'socket))
+ (systems (ly:paper-book-systems book))
+ (paper (ly:paper-book-paper book)))
(display (ly:format "paper ~4l\n" (get-page-dimensions paper)) ctor-arg)
(for-each (lambda (x)
- (let* ((system-stencil (paper-system-stencil x))
- (x-extent (ly:stencil-extent system-stencil X))
- (y-extent (ly:stencil-extent system-stencil Y)))
- (display (ly:format "system ~4l ~4l ~4l ~4l\n"
- (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg)
- (ly:outputter-dump-stencil outputter system-stencil)))
- systems)))
+ (let* ((system-stencil (paper-system-stencil x))
+ (x-extent (ly:stencil-extent system-stencil X))
+ (y-extent (ly:stencil-extent system-stencil Y)))
+ (display (ly:format "system ~4l ~4l ~4l ~4l\n"
+ (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg)
+ (ly:outputter-dump-stencil outputter system-stencil)))
+ systems)))
(define-public (convert-to-ps . args) #t)
(define-public (convert-to-pdf . args) #t)
(define-module (scm framework-svg))
(use-modules
- (guile)
- (lily)
- (scm page)
- (scm paper-system)
- (scm output-svg)
- (srfi srfi-1)
- (srfi srfi-2)
- (srfi srfi-13)
- (ice-9 regex))
+ (guile)
+ (lily)
+ (scm page)
+ (scm paper-system)
+ (scm output-svg)
+ (srfi srfi-1)
+ (srfi srfi-2)
+ (srfi srfi-13)
+ (ice-9 regex))
(define format ergonomic-simple-format)
`(width . ,(ly:format "~2fmm" (first rest)))
`(height . ,(ly:format "~2fmm" (second rest)))
`(viewBox . ,(ly:format "~4f ~4f ~4f ~4f"
- (third rest) (fourth rest)
- (fifth rest) (sixth rest)))))
+ (third rest) (fourth rest)
+ (fifth rest) (sixth rest)))))
(define (svg-end)
(ec 'svg))
(define (mkdirs dir-name mode)
(let loop ((dir-name (string-split dir-name #\/)) (root ""))
(if (pair? dir-name)
- (let ((dir (string-append root (car dir-name))))
- (if (not (file-exists? dir))
- (mkdir dir mode))
- (loop (cdr dir-name) (string-append dir "/"))))))
-
+ (let ((dir (string-append root (car dir-name))))
+ (if (not (file-exists? dir))
+ (mkdir dir mode))
+ (loop (cdr dir-name) (string-append dir "/"))))))
+
(define output-dir #f)
(define (svg-define-font font font-name scaling)
(let* ((base-file-name (basename (if (list? font) (pango-pf-file-name font)
- (ly:font-file-name font)) ".otf"))
- (woff-file-name (string-regexp-substitute "([.]otf)?$" ".woff"
- base-file-name))
- (woff-file (or (ly:find-file woff-file-name) "/no-such-file.woff"))
- (url (string-append output-dir "/fonts/" (lilypond-version) "/"
- (basename woff-file-name)))
- (lower-name (string-downcase font-name)))
+ (ly:font-file-name font)) ".otf"))
+ (woff-file-name (string-regexp-substitute "([.]otf)?$" ".woff"
+ base-file-name))
+ (woff-file (or (ly:find-file woff-file-name) "/no-such-file.woff"))
+ (url (string-append output-dir "/fonts/" (lilypond-version) "/"
+ (basename woff-file-name)))
+ (lower-name (string-downcase font-name)))
(if (file-exists? woff-file)
- (begin
- (if (not (file-exists? url))
- (begin
- (ly:message (_ "Updating font into: ~a") url)
- (mkdirs (string-append output-dir "/" (dirname url)) #o700)
- (copy-file woff-file url)
- (ly:progress "\n")))
- (ly:format
- "@font-face {
+ (begin
+ (if (not (file-exists? url))
+ (begin
+ (ly:message (_ "Updating font into: ~a") url)
+ (mkdirs (string-append output-dir "/" (dirname url)) #o700)
+ (copy-file woff-file url)
+ (ly:progress "\n")))
+ (ly:format
+ "@font-face {
font-family: '~a';
font-weight: normal;
font-style: normal;
src: url('~a');
}
"
- font-name url))
- "")))
+ font-name url))
+ "")))
(define (woff-header paper dir)
"TODO:
(define (dump-page paper filename page page-number page-count)
(let* ((outputter (ly:make-paper-outputter (open-file filename "wb") 'svg))
- (dump (lambda (str) (display str (ly:outputter-port outputter))))
- (lookup (lambda (x) (ly:output-def-lookup paper x)))
- (unit-length (lookup 'output-scale))
- (output-scale (* lily-unit->mm-factor unit-length))
- (device-width (lookup 'paper-width))
- (device-height (lookup 'paper-height))
- (page-width (* output-scale device-width))
- (page-height (* output-scale device-height)))
+ (dump (lambda (str) (display str (ly:outputter-port outputter))))
+ (lookup (lambda (x) (ly:output-def-lookup paper x)))
+ (unit-length (lookup 'output-scale))
+ (output-scale (* lily-unit->mm-factor unit-length))
+ (device-width (lookup 'paper-width))
+ (device-height (lookup 'paper-height))
+ (page-width (* output-scale device-width))
+ (page-height (* output-scale device-height)))
(if (ly:get-option 'svg-woff)
- (module-define! (ly:outputter-module outputter) 'paper paper))
+ (module-define! (ly:outputter-module outputter) 'paper paper))
(dump (svg-begin page-width page-height
- 0 0 device-width device-height))
+ 0 0 device-width device-height))
(if (ly:get-option 'svg-woff)
- (module-remove! (ly:outputter-module outputter) 'paper))
+ (module-remove! (ly:outputter-module outputter) 'paper))
(if (ly:get-option 'svg-woff)
- (dump (woff-header paper (dirname filename))))
+ (dump (woff-header paper (dirname filename))))
(dump (comment (format #f "Page: ~S/~S" page-number page-count)))
(ly:outputter-output-scheme outputter
- `(begin (set! lily-unit-length ,unit-length)
- ""))
+ `(begin (set! lily-unit-length ,unit-length)
+ ""))
(ly:outputter-dump-stencil outputter page)
(dump (svg-end))
(ly:outputter-close outputter)))
(define (dump-preview paper stencil filename)
(let* ((outputter (ly:make-paper-outputter (open-file filename "wb") 'svg))
- (dump (lambda (str) (display str (ly:outputter-port outputter))))
- (lookup (lambda (x) (ly:output-def-lookup paper x)))
- (unit-length (lookup 'output-scale))
- (x-extent (ly:stencil-extent stencil X))
- (y-extent (ly:stencil-extent stencil Y))
- (left-x (car x-extent))
- (top-y (cdr y-extent))
- (device-width (interval-length x-extent))
- (device-height (interval-length y-extent))
- (output-scale (* lily-unit->mm-factor unit-length))
- (svg-width (* output-scale device-width))
- (svg-height (* output-scale device-height)))
+ (dump (lambda (str) (display str (ly:outputter-port outputter))))
+ (lookup (lambda (x) (ly:output-def-lookup paper x)))
+ (unit-length (lookup 'output-scale))
+ (x-extent (ly:stencil-extent stencil X))
+ (y-extent (ly:stencil-extent stencil Y))
+ (left-x (car x-extent))
+ (top-y (cdr y-extent))
+ (device-width (interval-length x-extent))
+ (device-height (interval-length y-extent))
+ (output-scale (* lily-unit->mm-factor unit-length))
+ (svg-width (* output-scale device-width))
+ (svg-height (* output-scale device-height)))
(if (ly:get-option 'svg-woff)
- (module-define! (ly:outputter-module outputter) 'paper paper))
+ (module-define! (ly:outputter-module outputter) 'paper paper))
(dump (svg-begin svg-width svg-height
- left-x (- top-y) device-width device-height))
+ left-x (- top-y) device-width device-height))
(if (ly:get-option 'svg-woff)
- (module-remove! (ly:outputter-module outputter) 'paper))
+ (module-remove! (ly:outputter-module outputter) 'paper))
(if (ly:get-option 'svg-woff)
- (dump (woff-header paper (dirname filename))))
+ (dump (woff-header paper (dirname filename))))
(ly:outputter-output-scheme outputter
- `(begin (set! lily-unit-length ,unit-length)
- ""))
+ `(begin (set! lily-unit-length ,unit-length)
+ ""))
(ly:outputter-dump-stencil outputter stencil)
(dump (svg-end))
(ly:outputter-close outputter)))
(define (output-framework basename book scopes fields)
(let* ((paper (ly:paper-book-paper book))
- (page-stencils (map page-stencil (ly:paper-book-pages book)))
- (page-number (1- (ly:output-def-lookup paper 'first-page-number)))
- (page-count (length page-stencils))
- (filename "")
- (file-suffix (lambda (num)
- (if (= page-count 1) "" (format #f "-page-~a" num)))))
+ (page-stencils (map page-stencil (ly:paper-book-pages book)))
+ (page-number (1- (ly:output-def-lookup paper 'first-page-number)))
+ (page-count (length page-stencils))
+ (filename "")
+ (file-suffix (lambda (num)
+ (if (= page-count 1) "" (format #f "-page-~a" num)))))
(for-each
- (lambda (page)
- (set! page-number (1+ page-number))
- (set! filename (format #f "~a~a.svg"
- basename
- (file-suffix page-number)))
- (dump-page paper filename page page-number page-count))
- page-stencils)))
+ (lambda (page)
+ (set! page-number (1+ page-number))
+ (set! filename (format #f "~a~a.svg"
+ basename
+ (file-suffix page-number)))
+ (dump-page paper filename page page-number page-count))
+ page-stencils)))
(define (output-preview-framework basename book scopes fields)
(let* ((paper (ly:paper-book-paper book))
- (systems (relevant-book-systems book))
- (to-dump-systems (relevant-dump-systems systems)))
+ (systems (relevant-book-systems book))
+ (to-dump-systems (relevant-dump-systems systems)))
(dump-preview paper
- (stack-stencils Y DOWN 0.0
- (map paper-system-stencil
- (reverse to-dump-systems)))
- (format #f "~a.preview.svg" basename))))
+ (stack-stencils Y DOWN 0.0
+ (map paper-system-stencil
+ (reverse to-dump-systems)))
+ (format #f "~a.preview.svg" basename))))
"Return the x-extent of a string that goes from start-point
to end-point."
(let ((x1 (car start-point))
- (x2 (car end-point)))
+ (x2 (car end-point)))
(if (> x1 x2)
(cons x2 x1)
(cons x1 x2))))
"Return the y-extent of a string that goes from start-point
to end-point."
(let ((y1 (cdr start-point))
- (y2 (cdr end-point)))
+ (y2 (cdr end-point)))
(if (> y1 y2)
(cons y2 y1)
(cons y1 y2))))
(* 6 (/ (log mag) (log 2))))
(define (fret-count fret-range)
- "Calculate the fret count for the diagram given the range of frets in the diagram."
- (1+ (- (cdr fret-range) (car fret-range))))
+ "Calculate the fret count for the diagram given the range of frets in the diagram."
+ (1+ (- (cdr fret-range) (car fret-range))))
(define (subtract-base-fret base-fret dot-list)
"Subtract @var{base-fret} from every fret in @var{dot-list}"
(define (negate-extent extent)
"Return the extent in an axis opposite to the axis of @code{extent}."
- (cons (- (cdr extent)) (- (car extent))))
+ (cons (- (cdr extent)) (- (car extent))))
(define (stencil-fretboard-extent stencil fretboard-axis orientation)
"Return the extent of @code{stencil} in the @code{fretboard-axis}
direction."
(if (eq? fretboard-axis 'fret)
- (cond ((eq? orientation 'landscape)
- (ly:stencil-extent stencil X))
- ((eq? orientation 'opposing-landscape)
- (negate-extent (ly:stencil-extent stencil X)))
- (else
- (negate-extent (ly:stencil-extent stencil Y))))
- ;; else -- eq? fretboard-axis 'string
- (cond ((eq? orientation 'landscape)
- (ly:stencil-extent stencil Y))
- ((eq? orientation 'opposing-landscape)
- (negate-extent (ly:stencil-extent stencil Y)))
- (else
- (ly:stencil-extent stencil Y)))))
+ (cond ((eq? orientation 'landscape)
+ (ly:stencil-extent stencil X))
+ ((eq? orientation 'opposing-landscape)
+ (negate-extent (ly:stencil-extent stencil X)))
+ (else
+ (negate-extent (ly:stencil-extent stencil Y))))
+ ;; else -- eq? fretboard-axis 'string
+ (cond ((eq? orientation 'landscape)
+ (ly:stencil-extent stencil Y))
+ ((eq? orientation 'opposing-landscape)
+ (negate-extent (ly:stencil-extent stencil Y)))
+ (else
+ (ly:stencil-extent stencil Y)))))
(define (stencil-fretboard-offset stencil fretboard-axis orientation)
- "Return a the stencil coordinates of the center of @code{stencil}
+ "Return a the stencil coordinates of the center of @code{stencil}
in the @code{fretboard-axis} direction."
(* 0.5 (interval-length
- (stencil-fretboard-extent stencil fretboard-axis orientation))))
+ (stencil-fretboard-extent stencil fretboard-axis orientation))))
(define (string-thickness string thickness-factor)
;; markup commands and associated functions
(define (fret-parse-marking-list marking-list my-fret-count)
- "Parse a fret-diagram-verbose marking list into component sublists"
- (let* ((fret-range (cons 1 my-fret-count))
+ "Parse a fret-diagram-verbose marking list into component sublists"
+ (let* ((fret-range (cons 1 my-fret-count))
(capo-fret 0)
(barre-list '())
(dot-list '())
((eq? my-code 'barre)
(set! barre-list (cons* (cdr my-item) barre-list)))
((eq? my-code 'capo)
- (set! capo-fret (cadr my-item)))
+ (set! capo-fret (cadr my-item)))
((eq? my-code 'place-fret)
(set! dot-list (cons* (cdr my-item) dot-list))))
(parse-item (cdr mylist)))))
;; from FretBoard engraver, but not from markup call
(details (merge-details 'fret-diagram-details props '()))
(string-count
- (assoc-get 'string-count details 6)) ;; needed for everything
+ (assoc-get 'string-count details 6)) ;; needed for everything
(my-fret-count
- (assoc-get 'fret-count details 4)) ;; needed for everything
+ (assoc-get 'fret-count details 4)) ;; needed for everything
(orientation
- (assoc-get 'orientation details 'normal)) ;; needed for everything
+ (assoc-get 'orientation details 'normal)) ;; needed for everything
(finger-code
- (assoc-get
- 'finger-code details 'none)) ;; needed for draw-dots and draw-barre
+ (assoc-get
+ 'finger-code details 'none)) ;; needed for draw-dots and draw-barre
(default-dot-radius
(if (eq? finger-code 'in-dot) 0.425 0.25)) ;; bigger dots if labeled
(default-dot-position
(- 0.95 default-dot-radius)
0.6)) ; move up to make room for bigger dot if labeled
(dot-radius
- (assoc-get
- 'dot-radius details default-dot-radius))
- ;; needed for draw-dots and draw-barre
+ (assoc-get
+ 'dot-radius details default-dot-radius))
+ ;; needed for draw-dots and draw-barre
(dot-position
- (assoc-get
- 'dot-position details default-dot-position))
- ;; needed for draw-dots and draw-barre
+ (assoc-get
+ 'dot-position details default-dot-position))
+ ;; needed for draw-dots and draw-barre
(th
- (* (ly:output-def-lookup layout 'line-thickness)
- (chain-assoc-get 'thickness props 0.5)))
- ;; needed for draw-frets and draw-strings
+ (* (ly:output-def-lookup layout 'line-thickness)
+ (chain-assoc-get 'thickness props 0.5)))
+ ;; needed for draw-frets and draw-strings
(sth (* size th))
(thickness-factor (assoc-get 'string-thickness-factor details 0))
(alignment
- (chain-assoc-get 'align-dir props -0.4)) ;; needed only here
+ (chain-assoc-get 'align-dir props -0.4)) ;; needed only here
(xo-padding (assoc-get 'xo-padding details 0.2)) ;; needed only here
(parameters (fret-parse-marking-list marking-list my-fret-count))
(capo-fret (assoc-get 'capo-fret parameters 0))
(my-fret-count (fret-count fret-range))
(barre-list (assoc-get 'barre-list parameters))
(barre-type
- (assoc-get 'barre-type details 'curved))
+ (assoc-get 'barre-type details 'curved))
(fret-diagram-stencil '()))
;; Here are the fret diagram helper functions that depend on the
"Return a pair @code{(x-coordinate . y-coordinate)}
in stencil coordinate system."
(cond
- ((eq? orientation 'landscape)
- (cons fret-coordinate
- (- string-coordinate (1- string-count))))
- ((eq? orientation 'opposing-landscape)
- (cons (- fret-coordinate) (- string-coordinate)))
- (else
- (cons string-coordinate (- fret-coordinate)))))
+ ((eq? orientation 'landscape)
+ (cons fret-coordinate
+ (- string-coordinate (1- string-count))))
+ ((eq? orientation 'opposing-landscape)
+ (cons (- fret-coordinate) (- string-coordinate)))
+ (else
+ (cons string-coordinate (- fret-coordinate)))))
(define (stencil-coordinate-offset fret-offset string-offset)
"Return a pair @code{(x-offset . y-offset)}
for translation in stencil coordinate system."
(cond
- ((eq? orientation 'landscape)
- (cons fret-offset (- string-offset)))
- ((eq? orientation 'opposing-landscape)
- (cons (- fret-offset) string-offset))
- (else
- (cons string-offset (- fret-offset)))))
+ ((eq? orientation 'landscape)
+ (cons fret-offset (- string-offset)))
+ ((eq? orientation 'opposing-landscape)
+ (cons (- fret-offset) string-offset))
+ (else
+ (cons string-offset (- fret-offset)))))
string coordinate @var{start} to string-coordinate @var{stop} with a
baseline at fret coordinate @var{base}, a height of
@var{height}, and a half thickness of @var{half-thickness}."
- (let* ((width (+ (- stop start) 1))
- (cp-left-width (+ (* width half-thickness) start))
- (cp-right-width (- stop (* width half-thickness)))
- (bottom-control-point-height
- (- base (- height half-thickness)))
- (top-control-point-height
- (- base height))
- (left-end-point
- (stencil-coordinates base start))
- (right-end-point
- (stencil-coordinates base stop))
- (left-upper-control-point
- (stencil-coordinates
+ (let* ((width (+ (- stop start) 1))
+ (cp-left-width (+ (* width half-thickness) start))
+ (cp-right-width (- stop (* width half-thickness)))
+ (bottom-control-point-height
+ (- base (- height half-thickness)))
+ (top-control-point-height
+ (- base height))
+ (left-end-point
+ (stencil-coordinates base start))
+ (right-end-point
+ (stencil-coordinates base stop))
+ (left-upper-control-point
+ (stencil-coordinates
top-control-point-height cp-left-width))
- (left-lower-control-point
- (stencil-coordinates
+ (left-lower-control-point
+ (stencil-coordinates
bottom-control-point-height cp-left-width))
- (right-upper-control-point
- (stencil-coordinates
+ (right-upper-control-point
+ (stencil-coordinates
top-control-point-height cp-right-width))
- (right-lower-control-point
- (stencil-coordinates
+ (right-lower-control-point
+ (stencil-coordinates
bottom-control-point-height cp-right-width)))
- ;; order of bezier control points is:
- ;; left cp low, right cp low, right end low, left end low
- ;; right cp high, left cp high, left end high, right end high.
+ ;; order of bezier control points is:
+ ;; left cp low, right cp low, right end low, left end low
+ ;; right cp high, left cp high, left end high, right end high.
- (list left-lower-control-point
- right-lower-control-point
- right-end-point
- left-end-point
- right-upper-control-point
- left-upper-control-point
- left-end-point
- right-end-point)))
+ (list left-lower-control-point
+ right-lower-control-point
+ right-end-point
+ left-end-point
+ right-upper-control-point
+ left-upper-control-point
+ left-end-point
+ right-end-point)))
(define (draw-strings)
"Draw the string lines for a fret diagram with
(define (helper x)
(if (null? (cdr x))
- (string-stencil (car x))
- (ly:stencil-add
(string-stencil (car x))
- (helper (cdr x)))))
+ (ly:stencil-add
+ (string-stencil (car x))
+ (helper (cdr x)))))
(let* ( (string-list (map 1+ (iota string-count))))
(helper string-list)))
overall parameters."
(let* ((string-coordinate (- string-count string))
(current-string-thickness
- (* th size (string-thickness string thickness-factor)))
+ (* th size (string-thickness string thickness-factor)))
(fret-half-thickness (* size th 0.5))
(half-string (* current-string-thickness 0.5))
(start-coordinates
- (stencil-coordinates
- (- fret-half-thickness)
- (- (* size string-coordinate) half-string)))
+ (stencil-coordinates
+ (- fret-half-thickness)
+ (- (* size string-coordinate) half-string)))
(end-coordinates
- (stencil-coordinates
- (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
- (+ half-string (* size string-coordinate)))))
+ (stencil-coordinates
+ (+ fret-half-thickness (* size (1+ (fret-count fret-range))))
+ (+ half-string (* size string-coordinate)))))
(ly:round-filled-box
(string-x-extent start-coordinates end-coordinates)
(string-y-extent start-coordinates end-coordinates)
@var{size}. Orientation is given by @var{orientation}."
(define (helper x)
(if (null? (cdr x))
- (fret-stencil (car x))
- (ly:stencil-add
(fret-stencil (car x))
- (helper (cdr x)))))
+ (ly:stencil-add
+ (fret-stencil (car x))
+ (helper (cdr x)))))
(let ((fret-list (iota (1+ my-fret-count))))
(helper fret-list)))
- (define (fret-stencil fret)
- "Make a stencil for @code{fret}, given the
+ (define (fret-stencil fret)
+ "Make a stencil for @code{fret}, given the
fret-diagram overall parameters."
- (let* ((low-string-half-thickness
- (* 0.5
- size
- th
- (string-thickness string-count thickness-factor)))
- (fret-half-thickness (* 0.5 size th))
- (start-coordinates
- (stencil-coordinates
- (* size fret)
- (- fret-half-thickness low-string-half-thickness)))
- (end-coordinates
- (stencil-coordinates
- (* size fret)
- (* size (1- string-count)))))
- (make-line-stencil
- (* size th)
- (car start-coordinates) (cdr start-coordinates)
- (car end-coordinates) (cdr end-coordinates))))
-
- (define (draw-barre barre-list)
- "Create barre indications for a fret diagram"
- (if (not (null? barre-list))
- (let* ((string1 (caar barre-list))
- (string2 (cadar barre-list))
- (barre-fret (caddar barre-list))
- (top-fret (cdr fret-range))
- (low-fret (car fret-range))
- (fret (1+ (- barre-fret low-fret)))
- (barre-vertical-offset 0.5)
- (dot-center-fret-coordinate (+ (1- fret) dot-position))
- (barre-fret-coordinate
+ (let* ((low-string-half-thickness
+ (* 0.5
+ size
+ th
+ (string-thickness string-count thickness-factor)))
+ (fret-half-thickness (* 0.5 size th))
+ (start-coordinates
+ (stencil-coordinates
+ (* size fret)
+ (- fret-half-thickness low-string-half-thickness)))
+ (end-coordinates
+ (stencil-coordinates
+ (* size fret)
+ (* size (1- string-count)))))
+ (make-line-stencil
+ (* size th)
+ (car start-coordinates) (cdr start-coordinates)
+ (car end-coordinates) (cdr end-coordinates))))
+
+ (define (draw-barre barre-list)
+ "Create barre indications for a fret diagram"
+ (if (not (null? barre-list))
+ (let* ((string1 (caar barre-list))
+ (string2 (cadar barre-list))
+ (barre-fret (caddar barre-list))
+ (top-fret (cdr fret-range))
+ (low-fret (car fret-range))
+ (fret (1+ (- barre-fret low-fret)))
+ (barre-vertical-offset 0.5)
+ (dot-center-fret-coordinate (+ (1- fret) dot-position))
+ (barre-fret-coordinate
(+ dot-center-fret-coordinate
(* (- barre-vertical-offset 0.5) dot-radius)))
- (barre-start-string-coordinate (- string-count string1))
- (barre-end-string-coordinate (- string-count string2))
- (scale-dot-radius (* size dot-radius))
- (barre-type (assoc-get 'barre-type details 'curved))
- (barre-stencil
+ (barre-start-string-coordinate (- string-count string1))
+ (barre-end-string-coordinate (- string-count string2))
+ (scale-dot-radius (* size dot-radius))
+ (barre-type (assoc-get 'barre-type details 'curved))
+ (barre-stencil
(cond
- ((eq? barre-type 'straight)
- (make-straight-barre-stencil
- barre-fret-coordinate
- barre-start-string-coordinate
- barre-end-string-coordinate
- scale-dot-radius))
- ((eq? barre-type 'curved)
- (make-curved-barre-stencil
- barre-fret-coordinate
- barre-start-string-coordinate
- barre-end-string-coordinate
- scale-dot-radius)))))
- (if (not (null? (cdr barre-list)))
- (ly:stencil-add
- barre-stencil
- (draw-barre (cdr barre-list)))
- barre-stencil ))))
-
- (define (make-straight-barre-stencil
- fret-coordinate
- start-string-coordinate
- end-string-coordinate
- half-thickness)
- "Create a straight barre stencil."
- (let ((start-point
- (stencil-coordinates
- (* size fret-coordinate)
- (* size start-string-coordinate)))
- (end-point
- (stencil-coordinates
- (* size fret-coordinate)
- (* size end-string-coordinate))))
- (make-line-stencil
- half-thickness
- (car start-point)
- (cdr start-point)
- (car end-point)
- (cdr end-point))))
-
- (define (make-curved-barre-stencil
- fret-coordinate
- start-string-coordinate
- end-string-coordinate
- half-thickness)
- "Create a curved barre stencil."
- (let* ((bezier-thick 0.1)
- (bezier-height 0.5)
- (bezier-list
- (make-bezier-sandwich-list
- (* size start-string-coordinate)
- (* size end-string-coordinate)
- (* size fret-coordinate)
+ ((eq? barre-type 'straight)
+ (make-straight-barre-stencil
+ barre-fret-coordinate
+ barre-start-string-coordinate
+ barre-end-string-coordinate
+ scale-dot-radius))
+ ((eq? barre-type 'curved)
+ (make-curved-barre-stencil
+ barre-fret-coordinate
+ barre-start-string-coordinate
+ barre-end-string-coordinate
+ scale-dot-radius)))))
+ (if (not (null? (cdr barre-list)))
+ (ly:stencil-add
+ barre-stencil
+ (draw-barre (cdr barre-list)))
+ barre-stencil ))))
+
+ (define (make-straight-barre-stencil
+ fret-coordinate
+ start-string-coordinate
+ end-string-coordinate
+ half-thickness)
+ "Create a straight barre stencil."
+ (let ((start-point
+ (stencil-coordinates
+ (* size fret-coordinate)
+ (* size start-string-coordinate)))
+ (end-point
+ (stencil-coordinates
+ (* size fret-coordinate)
+ (* size end-string-coordinate))))
+ (make-line-stencil
+ half-thickness
+ (car start-point)
+ (cdr start-point)
+ (car end-point)
+ (cdr end-point))))
+
+ (define (make-curved-barre-stencil
+ fret-coordinate
+ start-string-coordinate
+ end-string-coordinate
+ half-thickness)
+ "Create a curved barre stencil."
+ (let* ((bezier-thick 0.1)
+ (bezier-height 0.5)
+ (bezier-list
+ (make-bezier-sandwich-list
+ (* size start-string-coordinate)
+ (* size end-string-coordinate)
+ (* size fret-coordinate)
+ (* size bezier-height)
+ (* size bezier-thick)))
+ (box-lower-left
+ (stencil-coordinates
+ (+ (* size fret-coordinate) half-thickness)
+ (- (* size start-string-coordinate) half-thickness)))
+ (box-upper-right
+ (stencil-coordinates
+ (- (* size fret-coordinate)
(* size bezier-height)
- (* size bezier-thick)))
- (box-lower-left
- (stencil-coordinates
- (+ (* size fret-coordinate) half-thickness)
- (- (* size start-string-coordinate) half-thickness)))
- (box-upper-right
- (stencil-coordinates
- (- (* size fret-coordinate)
- (* size bezier-height)
- half-thickness)
- (+ (* size end-string-coordinate) half-thickness)))
- (x-extent (cons (car box-lower-left) (car box-upper-right)))
- (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
- (make-bezier-sandwich-stencil
- bezier-list
- (* size bezier-thick)
- x-extent
- y-extent)))
-
- (define (draw-dots dot-list)
- "Make dots for fret diagram."
-
- (let* ( (scale-dot-radius (* size dot-radius))
+ half-thickness)
+ (+ (* size end-string-coordinate) half-thickness)))
+ (x-extent (cons (car box-lower-left) (car box-upper-right)))
+ (y-extent (cons (cdr box-lower-left) (cdr box-upper-right))))
+ (make-bezier-sandwich-stencil
+ bezier-list
+ (* size bezier-thick)
+ x-extent
+ y-extent)))
+
+ (define (draw-dots dot-list)
+ "Make dots for fret diagram."
+
+ (let* ( (scale-dot-radius (* size dot-radius))
(scale-dot-thick (* size th))
(default-dot-color (assoc-get 'dot-color details 'black))
(finger-label-padding 0.3)
(dot-label-font-mag
- (* scale-dot-radius
- (assoc-get 'dot-label-font-mag details 1.0)))
+ (* scale-dot-radius
+ (assoc-get 'dot-label-font-mag details 1.0)))
(string-label-font-mag
- (* size
- (assoc-get
- 'string-label-font-mag details
- (cond ((or (eq? orientation 'landscape)
- (eq? orientation 'opposing-landscape))
- 0.5)
- (else 0.6)))))
+ (* size
+ (assoc-get
+ 'string-label-font-mag details
+ (cond ((or (eq? orientation 'landscape)
+ (eq? orientation 'opposing-landscape))
+ 0.5)
+ (else 0.6)))))
(mypair (car dot-list))
(restlist (cdr dot-list))
(string (car mypair))
(fret-coordinate (* size (+ (1- fret) dot-position)))
(string-coordinate (* size (- string-count string)))
(dot-coordinates
- (stencil-coordinates fret-coordinate string-coordinate))
+ (stencil-coordinates fret-coordinate string-coordinate))
(extent (cons (- scale-dot-radius) scale-dot-radius))
(finger (caddr mypair))
(finger (if (number? finger) (number->string finger) finger))
'white
'black))
(dot-stencil (if (eq? dot-color 'white)
- (ly:stencil-add
- (make-circle-stencil
+ (ly:stencil-add
+ (make-circle-stencil
scale-dot-radius scale-dot-thick #t)
- (ly:stencil-in-color
+ (ly:stencil-in-color
(make-circle-stencil
- (- scale-dot-radius (* 0.5 scale-dot-thick))
- 0 #t)
+ (- scale-dot-radius (* 0.5 scale-dot-thick))
+ 0 #t)
1 1 1))
- (make-circle-stencil
- scale-dot-radius scale-dot-thick #t)))
+ (make-circle-stencil
+ scale-dot-radius scale-dot-thick #t)))
(positioned-dot
- (ly:stencil-translate dot-stencil dot-coordinates))
+ (ly:stencil-translate dot-stencil dot-coordinates))
(labeled-dot-stencil
- (cond
- ((or (eq? finger '())(eq? finger-code 'none))
- positioned-dot)
- ((eq? finger-code 'in-dot)
- (let ((finger-label
- (centered-stencil
- (sans-serif-stencil
- layout props dot-label-font-mag finger))))
- (ly:stencil-translate
- (ly:stencil-add
- dot-stencil
- (if (eq? dot-color 'white)
- finger-label
- (ly:stencil-in-color finger-label 1 1 1)))
- dot-coordinates)))
- ((eq? finger-code 'below-string)
- (let* ((label-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props string-label-font-mag
- finger)))
- (label-fret-offset
- (stencil-fretboard-offset
- label-stencil 'fret orientation))
- (label-fret-coordinate
- (+ (* size
- (+ 1 my-fret-count finger-label-padding))
- label-fret-offset))
- (label-string-coordinate string-coordinate)
- (label-translation
- (stencil-coordinates
- label-fret-coordinate
- label-string-coordinate)))
- (ly:stencil-add
- positioned-dot
- (ly:stencil-translate
- label-stencil
- label-translation))))
- (else ;unknown finger-code
- positioned-dot))))
- (if (null? restlist)
- labeled-dot-stencil
- (ly:stencil-add
+ (cond
+ ((or (eq? finger '())(eq? finger-code 'none))
+ positioned-dot)
+ ((eq? finger-code 'in-dot)
+ (let ((finger-label
+ (centered-stencil
+ (sans-serif-stencil
+ layout props dot-label-font-mag finger))))
+ (ly:stencil-translate
+ (ly:stencil-add
+ dot-stencil
+ (if (eq? dot-color 'white)
+ finger-label
+ (ly:stencil-in-color finger-label 1 1 1)))
+ dot-coordinates)))
+ ((eq? finger-code 'below-string)
+ (let* ((label-stencil
+ (centered-stencil
+ (sans-serif-stencil
+ layout props string-label-font-mag
+ finger)))
+ (label-fret-offset
+ (stencil-fretboard-offset
+ label-stencil 'fret orientation))
+ (label-fret-coordinate
+ (+ (* size
+ (+ 1 my-fret-count finger-label-padding))
+ label-fret-offset))
+ (label-string-coordinate string-coordinate)
+ (label-translation
+ (stencil-coordinates
+ label-fret-coordinate
+ label-string-coordinate)))
+ (ly:stencil-add
+ positioned-dot
+ (ly:stencil-translate
+ label-stencil
+ label-translation))))
+ (else ;unknown finger-code
+ positioned-dot))))
+ (if (null? restlist)
+ labeled-dot-stencil
+ (ly:stencil-add
(draw-dots restlist)
labeled-dot-stencil))))
- (define (draw-thick-zero-fret)
- "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
- (let* ((half-lowest-string-thickness
- (* 0.5 th (string-thickness string-count thickness-factor)))
- (half-thick (* 0.5 sth))
- (top-fret-thick
- (* sth (assoc-get 'top-fret-thickness details 3.0)))
- (start-string-coordinate (- half-lowest-string-thickness))
- (end-string-coordinate (+ (* size (1- string-count)) half-thick))
- (start-fret-coordinate half-thick)
- (end-fret-coordinate (- half-thick top-fret-thick))
- (lower-left
- (stencil-coordinates
- start-fret-coordinate start-string-coordinate))
- (upper-right
- (stencil-coordinates
- end-fret-coordinate end-string-coordinate)))
- (ly:round-filled-box
- ;; Put limits in order, or else the intervals are considered empty
- (ordered-cons (car lower-left) (car upper-right))
- (ordered-cons (cdr lower-left) (cdr upper-right))
- sth)))
-
- (define (draw-xo xo-list)
- "Put open and mute string indications on diagram, as contained in
+ (define (draw-thick-zero-fret)
+ "Draw a thick zeroth fret for a fret diagram whose base fret is 1."
+ (let* ((half-lowest-string-thickness
+ (* 0.5 th (string-thickness string-count thickness-factor)))
+ (half-thick (* 0.5 sth))
+ (top-fret-thick
+ (* sth (assoc-get 'top-fret-thickness details 3.0)))
+ (start-string-coordinate (- half-lowest-string-thickness))
+ (end-string-coordinate (+ (* size (1- string-count)) half-thick))
+ (start-fret-coordinate half-thick)
+ (end-fret-coordinate (- half-thick top-fret-thick))
+ (lower-left
+ (stencil-coordinates
+ start-fret-coordinate start-string-coordinate))
+ (upper-right
+ (stencil-coordinates
+ end-fret-coordinate end-string-coordinate)))
+ (ly:round-filled-box
+ ;; Put limits in order, or else the intervals are considered empty
+ (ordered-cons (car lower-left) (car upper-right))
+ (ordered-cons (cdr lower-left) (cdr upper-right))
+ sth)))
+
+ (define (draw-xo xo-list)
+ "Put open and mute string indications on diagram, as contained in
@var{xo-list}."
- (let* ((xo-font-mag
- (assoc-get 'xo-font-magnification details
- (cond ((or (eq? orientation 'landscape)
- (eq? orientation 'opposing-landscape))
- 0.4)
- (else 0.4))))
- (mypair (car xo-list))
- (restlist (cdr xo-list))
- (glyph-string (if (eq? (car mypair) 'mute)
- (assoc-get 'mute-string details "X")
- (assoc-get 'open-string details "O")))
- (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
- (glyph-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props (* size xo-font-mag) glyph-string)))
- (glyph-stencil-coordinates
- (stencil-coordinates 0 glyph-string-coordinate))
- (positioned-glyph
- (ly:stencil-translate
- glyph-stencil
- glyph-stencil-coordinates)))
- (if (null? restlist)
- positioned-glyph
- (ly:stencil-add
+ (let* ((xo-font-mag
+ (assoc-get 'xo-font-magnification details
+ (cond ((or (eq? orientation 'landscape)
+ (eq? orientation 'opposing-landscape))
+ 0.4)
+ (else 0.4))))
+ (mypair (car xo-list))
+ (restlist (cdr xo-list))
+ (glyph-string (if (eq? (car mypair) 'mute)
+ (assoc-get 'mute-string details "X")
+ (assoc-get 'open-string details "O")))
+ (glyph-string-coordinate (* (- string-count (cadr mypair)) size))
+ (glyph-stencil
+ (centered-stencil
+ (sans-serif-stencil
+ layout props (* size xo-font-mag) glyph-string)))
+ (glyph-stencil-coordinates
+ (stencil-coordinates 0 glyph-string-coordinate))
+ (positioned-glyph
+ (ly:stencil-translate
+ glyph-stencil
+ glyph-stencil-coordinates)))
+ (if (null? restlist)
+ positioned-glyph
+ (ly:stencil-add
positioned-glyph
(draw-xo restlist)))))
- (define (draw-capo fret)
- "Draw a capo indicator across the full width of the fret-board
+ (define (draw-capo fret)
+ "Draw a capo indicator across the full width of the fret-board
at @var{fret}."
- (let* ((capo-thick
- (* size (assoc-get 'capo-thickness details 0.5)))
- (half-thick (* capo-thick 0.5))
- (last-string-position 0)
- (first-string-position (* size (- string-count 1)))
- (fret-position ( * size (1- (+ dot-position fret))))
- (start-point
- (stencil-coordinates
- fret-position
- first-string-position))
- (end-point
- (stencil-coordinates
- fret-position
- last-string-position)))
- (make-line-stencil
- capo-thick
- (car start-point) (cdr start-point)
- (car end-point) (cdr end-point))))
-
- (define (label-fret fret-range)
- "Label the base fret on a fret diagram"
- (let* ((base-fret (car fret-range))
- (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
- (label-space (* 0.5 size))
- (label-dir (assoc-get 'label-dir details RIGHT))
- (label-vertical-offset
- (assoc-get 'fret-label-vertical-offset details 0))
- (number-type
- (assoc-get 'number-type details 'roman-lower))
- (label-text
- (cond
- ((equal? number-type 'roman-lower)
- (fancy-format #f "~(~@r~)" base-fret))
- ((equal? number-type 'roman-upper)
- (fancy-format #f "~@r" base-fret))
- ((equal? 'arabic number-type)
- (fancy-format #f "~d" base-fret))
- ((equal? 'custom number-type)
- (fancy-format #f
- (assoc-get 'fret-label-custom-format
- details "~a")
- base-fret))
- (else (fancy-format #f "~(~@r~)" base-fret))))
- (label-stencil
- (centered-stencil
- (sans-serif-stencil
- layout props (* size label-font-mag) label-text)))
- (label-half-width
- (stencil-fretboard-offset
- label-stencil
- 'string
- orientation))
- (label-outside-diagram (+ label-space label-half-width)))
- (ly:stencil-translate
- label-stencil
+ (let* ((capo-thick
+ (* size (assoc-get 'capo-thickness details 0.5)))
+ (half-thick (* capo-thick 0.5))
+ (last-string-position 0)
+ (first-string-position (* size (- string-count 1)))
+ (fret-position ( * size (1- (+ dot-position fret))))
+ (start-point
(stencil-coordinates
- (* size (+ 1.0 label-vertical-offset))
- (if (eq? label-dir LEFT)
- (- label-outside-diagram)
- (+ (* size (1- string-count)) label-outside-diagram))))))
-
- ;; Here is the body of make-fret-diagram
+ fret-position
+ first-string-position))
+ (end-point
+ (stencil-coordinates
+ fret-position
+ last-string-position)))
+ (make-line-stencil
+ capo-thick
+ (car start-point) (cdr start-point)
+ (car end-point) (cdr end-point))))
+
+ (define (label-fret fret-range)
+ "Label the base fret on a fret diagram"
+ (let* ((base-fret (car fret-range))
+ (label-font-mag (assoc-get 'fret-label-font-mag details 0.5))
+ (label-space (* 0.5 size))
+ (label-dir (assoc-get 'label-dir details RIGHT))
+ (label-vertical-offset
+ (assoc-get 'fret-label-vertical-offset details 0))
+ (number-type
+ (assoc-get 'number-type details 'roman-lower))
+ (label-text
+ (cond
+ ((equal? number-type 'roman-lower)
+ (fancy-format #f "~(~@r~)" base-fret))
+ ((equal? number-type 'roman-upper)
+ (fancy-format #f "~@r" base-fret))
+ ((equal? 'arabic number-type)
+ (fancy-format #f "~d" base-fret))
+ ((equal? 'custom number-type)
+ (fancy-format #f
+ (assoc-get 'fret-label-custom-format
+ details "~a")
+ base-fret))
+ (else (fancy-format #f "~(~@r~)" base-fret))))
+ (label-stencil
+ (centered-stencil
+ (sans-serif-stencil
+ layout props (* size label-font-mag) label-text)))
+ (label-half-width
+ (stencil-fretboard-offset
+ label-stencil
+ 'string
+ orientation))
+ (label-outside-diagram (+ label-space label-half-width)))
+ (ly:stencil-translate
+ label-stencil
+ (stencil-coordinates
+ (* size (+ 1.0 label-vertical-offset))
+ (if (eq? label-dir LEFT)
+ (- label-outside-diagram)
+ (+ (* size (1- string-count)) label-outside-diagram))))))
+
+ ;; Here is the body of make-fret-diagram
(set! fret-diagram-stencil
- (ly:stencil-add (draw-strings) (draw-frets)))
+ (ly:stencil-add (draw-strings) (draw-frets)))
(if (and (not (null? barre-list))
(not (eq? 'none barre-type)))
- (set! fret-diagram-stencil
- (ly:stencil-add
- (draw-barre barre-list)
- fret-diagram-stencil)))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ (draw-barre barre-list)
+ fret-diagram-stencil)))
(if (not (null? dot-list))
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-dots dot-list))))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (draw-dots dot-list))))
(if (= (car fret-range) 1)
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-thick-zero-fret))))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (draw-thick-zero-fret))))
(if (not (null? xo-list))
- (let* ((diagram-fret-top
- (car (stencil-fretboard-extent
+ (let* ((diagram-fret-top
+ (car (stencil-fretboard-extent
fret-diagram-stencil
'fret
orientation)))
- (xo-stencil (draw-xo xo-list))
- (xo-fret-offset
- (stencil-fretboard-offset
+ (xo-stencil (draw-xo xo-list))
+ (xo-fret-offset
+ (stencil-fretboard-offset
xo-stencil 'fret orientation))
- (xo-stencil-offset
- (stencil-coordinate-offset
- (- diagram-fret-top
- xo-fret-offset
- (* size xo-padding))
- 0)))
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (ly:stencil-translate
- xo-stencil
- xo-stencil-offset)))))
+ (xo-stencil-offset
+ (stencil-coordinate-offset
+ (- diagram-fret-top
+ xo-fret-offset
+ (* size xo-padding))
+ 0)))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (ly:stencil-translate
+ xo-stencil
+ xo-stencil-offset)))))
(if (> capo-fret 0)
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (draw-capo capo-fret))))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (draw-capo capo-fret))))
(if (> (car fret-range) 1)
- (set! fret-diagram-stencil
- (ly:stencil-add
- fret-diagram-stencil
- (label-fret fret-range))))
+ (set! fret-diagram-stencil
+ (ly:stencil-add
+ fret-diagram-stencil
+ (label-fret fret-range))))
(ly:stencil-aligned-to fret-diagram-stencil X alignment)))
(define (fret-parse-definition-string props definition-string)
- "Parse a fret diagram string and return a pair containing:
+ "Parse a fret diagram string and return a pair containing:
@var{props}, modified as necessary by the definition-string
a fret-indication list with the appropriate values"
- (let* ((fret-count 4)
- (string-count 6)
- (fret-range (cons 1 fret-count))
- (barre-list '())
- (dot-list '())
- (xo-list '())
- (output-list '())
- (new-props '())
- (details (merge-details 'fret-diagram-details props '()))
- (items (string-split definition-string #\;)))
- (let parse-item ((myitems items))
- (if (not (null? (cdr myitems)))
- (let ((test-string (car myitems)))
- (case (car (string->list (substring test-string 0 1)))
- ((#\s) (let ((size (get-numeric-from-key test-string)))
- (set! props (prepend-alist-chain 'size size props))))
- ((#\t) (let ((th (get-numeric-from-key test-string)))
- (set! props (prepend-alist-chain 'thickness th props))))
- ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
- (finger-id (case finger-code
- ((0) 'none)
- ((1) 'in-dot)
- ((2) 'below-string))))
- (set! details
- (acons 'finger-code finger-id details))))
- ((#\c) (set! output-list
- (cons-fret
- (cons
- 'barre
- (numerify
- (string-split (substring test-string 2) #\-)))
- output-list)))
- ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
- (set! details
- (acons 'fret-count fret-count details))))
- ((#\w) (let ((string-count (get-numeric-from-key test-string)))
- (set! details
- (acons 'string-count string-count details))))
- ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
- (set! details
- (acons 'dot-radius dot-size details))))
- ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
- (set! details
- (acons 'dot-position dot-position details))))
- (else
- (let ((this-list (string-split test-string #\-)))
- (if (string->number (cadr this-list))
- (set! output-list
- (cons-fret
- (cons 'place-fret (numerify this-list))
- output-list))
- (if (equal? (cadr this-list) "x" )
- (set! output-list
- (cons-fret
- (list 'mute (string->number (car this-list)))
- output-list))
- (set! output-list
- (cons-fret
- (list 'open (string->number (car this-list)))
- output-list)))))))
- (parse-item (cdr myitems)))))
- ;; add the modified details
- (set! props
- (prepend-alist-chain 'fret-diagram-details details props))
- `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
+ (let* ((fret-count 4)
+ (string-count 6)
+ (fret-range (cons 1 fret-count))
+ (barre-list '())
+ (dot-list '())
+ (xo-list '())
+ (output-list '())
+ (new-props '())
+ (details (merge-details 'fret-diagram-details props '()))
+ (items (string-split definition-string #\;)))
+ (let parse-item ((myitems items))
+ (if (not (null? (cdr myitems)))
+ (let ((test-string (car myitems)))
+ (case (car (string->list (substring test-string 0 1)))
+ ((#\s) (let ((size (get-numeric-from-key test-string)))
+ (set! props (prepend-alist-chain 'size size props))))
+ ((#\t) (let ((th (get-numeric-from-key test-string)))
+ (set! props (prepend-alist-chain 'thickness th props))))
+ ((#\f) (let* ((finger-code (get-numeric-from-key test-string))
+ (finger-id (case finger-code
+ ((0) 'none)
+ ((1) 'in-dot)
+ ((2) 'below-string))))
+ (set! details
+ (acons 'finger-code finger-id details))))
+ ((#\c) (set! output-list
+ (cons-fret
+ (cons
+ 'barre
+ (numerify
+ (string-split (substring test-string 2) #\-)))
+ output-list)))
+ ((#\h) (let ((fret-count (get-numeric-from-key test-string)))
+ (set! details
+ (acons 'fret-count fret-count details))))
+ ((#\w) (let ((string-count (get-numeric-from-key test-string)))
+ (set! details
+ (acons 'string-count string-count details))))
+ ((#\d) (let ((dot-size (get-numeric-from-key test-string)))
+ (set! details
+ (acons 'dot-radius dot-size details))))
+ ((#\p) (let ((dot-position (get-numeric-from-key test-string)))
+ (set! details
+ (acons 'dot-position dot-position details))))
+ (else
+ (let ((this-list (string-split test-string #\-)))
+ (if (string->number (cadr this-list))
+ (set! output-list
+ (cons-fret
+ (cons 'place-fret (numerify this-list))
+ output-list))
+ (if (equal? (cadr this-list) "x" )
+ (set! output-list
+ (cons-fret
+ (list 'mute (string->number (car this-list)))
+ output-list))
+ (set! output-list
+ (cons-fret
+ (list 'open (string->number (car this-list)))
+ output-list)))))))
+ (parse-item (cdr myitems)))))
+ ;; add the modified details
+ (set! props
+ (prepend-alist-chain 'fret-diagram-details details props))
+ `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better
(define-public
(fret-parse-terse-definition-string props definition-string)
@var{props}, modified to include the string-count determined by the
definition-string, and
a fret-indication list with the appropriate values"
-;; TODO -- change syntax to fret\string-finger
+ ;; TODO -- change syntax to fret\string-finger
(let* ((details (merge-details 'fret-diagram-details props '()))
(barre-start-list '())
(pair?) ; argument type (list, but use pair? for speed)
#:category instrument-specific-markup ; markup type
#:properties ((align-dir -0.4) ; properties and defaults
- (size 1.0)
- (fret-diagram-details)
- (thickness 0.5))
+ (size 1.0)
+ (fret-diagram-details)
+ (thickness 0.5))
"Make a fret diagram containing the symbols indicated in @var{marking-list}.
For example,
(fret-diagram-verbose-markup layout
(car definition-list)
(cdr definition-list))))
-
-
#:use-module (lily)
#:export
(make-empty-graph add-node add-edge add-cluster
- graph-write
- ))
+ graph-write
+ ))
(define graph-type (make-record-type "graph" '(nodes edges clusters name)))
(define (add-cluster graph node-id cluster-name)
(let* ((cs (clusters graph))
- (cluster (assoc cluster-name cs))
- (already-in-cluster (if cluster
- (cdr cluster)
- '())))
+ (cluster (assoc cluster-name cs))
+ (already-in-cluster (if cluster
+ (cdr cluster)
+ '())))
(set-clusters! graph (assoc-set! cs
- cluster-name
- (cons node-id already-in-cluster)))))
+ cluster-name
+ (cons node-id already-in-cluster)))))
(define (add-node graph label . cluster-name)
(let* ((ns (nodes graph))
(id (length ns)))
(set-nodes! graph (assv-set! ns id label))
(if (and (not (null? cluster-name))
- (string? (car cluster-name)))
- (add-cluster graph id (car cluster-name)))
+ (string? (car cluster-name)))
+ (add-cluster graph id (car cluster-name)))
id))
(define (add-edge graph node1 node2)
(define (graph-write graph out)
(let ((ns (nodes graph))
- (es (edges graph))
- (cs (clusters graph)))
+ (es (edges graph))
+ (cs (clusters graph)))
(ly:message (format #f (_ "Writing graph `~a'...") (port-filename out)))
(display "digraph G {\nrankdir=\"LR\"\nnode [shape=rectangle]\n" out)
(for-each (lambda (n) (format out "~a [label=\"~a\"]\n" (car n) (cdr n)))
- ns)
+ ns)
(for-each (lambda (e) (format out "~a -> ~a\n" (car e) (cdr e)))
- es)
+ es)
(for-each (lambda (c)
- (format out "subgraph cluster_~a {\nlabel= \"~a\"\ncolor=blue\n"
- (string-filter (car c) char-alphabetic?)
- (car c))
- (for-each (lambda (n) (format out "~a\n" n)) (cdr c))
- (display "}\n" out))
- cs)
+ (format out "subgraph cluster_~a {\nlabel= \"~a\"\ncolor=blue\n"
+ (string-filter (car c) char-alphabetic?)
+ (car c))
+ (for-each (lambda (n) (format out "~a\n" n)) (cdr c))
+ (display "}\n" out))
+ cs)
(display "}" out)))
#:use-module (ice-9 debugging ice-9-debugger-extensions)
#:use-module (ice-9 readline)
#:export (set-break!
- clear-break!
- set-trace-call!
- clear-trace-call!
- set-trace-subtree!
- clear-trace-subtree!
- debug-help))
+ clear-break!
+ set-trace-call!
+ clear-trace-call!
+ set-trace-subtree!
+ clear-trace-subtree!
+ debug-help))
(define (set-break! proc)
(install-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour debug-trap)))
+ #:procedure proc
+ #:behaviour debug-trap)))
(define (clear-break! proc)
(uninstall-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour debug-trap)))
+ #:procedure proc
+ #:behaviour debug-trap)))
(define (set-trace-call! proc)
(install-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour (list trace-trap
- trace-at-exit))))
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-at-exit))))
(define (clear-trace-call! proc)
(uninstall-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour (list trace-trap
- trace-at-exit))))
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-at-exit))))
(define (set-trace-subtree! proc)
(install-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour (list trace-trap
- trace-until-exit))))
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-until-exit))))
(define (clear-trace-subtree! proc)
(uninstall-trap (make <procedure-trap>
- #:procedure proc
- #:behaviour (list trace-trap
- trace-until-exit))))
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-until-exit))))
(define (debug-help )
(display "\nYou may add the following commands as debugging statements in your source file\n")
(define-markup-command (harp-pedal layout props definition-string) (string?)
#:category instrument-specific-markup ; markup type for the documentation!
#:properties ((size 1.2)
- (harp-pedal-details '())
- (thickness 0.5))
+ (harp-pedal-details '())
+ (thickness 0.5))
"Make a harp pedal diagram.
Possible elements in @var{definition-string}:
@end lilypond
"
(let* ((pedal-list (harp-pedals-parse-string definition-string))
- (details (begin (harp-pedal-check pedal-list) harp-pedal-details))
- (dy (* size (assoc-get 'box-offset details 0.8))) ; offset of the box center from the line
- (line-width (* (ly:output-def-lookup layout 'line-thickness)
- (chain-assoc-get 'thickness props 0.5)))
- (box-width (* size (assoc-get 'box-width details 0.4)))
- (box-hheight (* size (/ (assoc-get 'box-height details 1.0) 2))) ; half the box-height, saves some divisions by 2
- (spacebeforedivider (* size (assoc-get 'space-before-divider details 0.8))) ; full space between boxes before the first divider
- (spaceafterdivider (* size (assoc-get 'space-after-divider details 0.8))) ; full space between boxes
- (circle-thickness (* (ly:output-def-lookup layout 'line-thickness)
- (assoc-get 'circle-thickness details 0.5)))
- (circle-x-padding (* size (assoc-get 'circle-x-padding details 0.15)))
- (circle-y-padding (* size (assoc-get 'circle-y-padding details 0.2)))
- (box-x-dimensions (lambda (prev-x p space) (cons (+ prev-x space)
- (+ prev-x space box-width))))
- (box-y-dimensions (lambda (prev-x p space) (cons (- (* p dy) box-hheight)
- (+ (* p dy) box-hheight))))
- (divider-stencil (lambda (xpos) (make-line-stencil line-width
- xpos (- 0 dy box-hheight)
- xpos (+ dy box-hheight))))
- (result (let process-pedal ((remaining pedal-list)
- (prev-x 0)
- (stencils '())
- (circled #f)
- (space spacebeforedivider))
- ;; Terminal condition of the recursion, return (final-x . stencil-list)
- (if (null? remaining)
- (cons (+ prev-x space) (reverse stencils))
+ (details (begin (harp-pedal-check pedal-list) harp-pedal-details))
+ (dy (* size (assoc-get 'box-offset details 0.8))) ; offset of the box center from the line
+ (line-width (* (ly:output-def-lookup layout 'line-thickness)
+ (chain-assoc-get 'thickness props 0.5)))
+ (box-width (* size (assoc-get 'box-width details 0.4)))
+ (box-hheight (* size (/ (assoc-get 'box-height details 1.0) 2))) ; half the box-height, saves some divisions by 2
+ (spacebeforedivider (* size (assoc-get 'space-before-divider details 0.8))) ; full space between boxes before the first divider
+ (spaceafterdivider (* size (assoc-get 'space-after-divider details 0.8))) ; full space between boxes
+ (circle-thickness (* (ly:output-def-lookup layout 'line-thickness)
+ (assoc-get 'circle-thickness details 0.5)))
+ (circle-x-padding (* size (assoc-get 'circle-x-padding details 0.15)))
+ (circle-y-padding (* size (assoc-get 'circle-y-padding details 0.2)))
+ (box-x-dimensions (lambda (prev-x p space) (cons (+ prev-x space)
+ (+ prev-x space box-width))))
+ (box-y-dimensions (lambda (prev-x p space) (cons (- (* p dy) box-hheight)
+ (+ (* p dy) box-hheight))))
+ (divider-stencil (lambda (xpos) (make-line-stencil line-width
+ xpos (- 0 dy box-hheight)
+ xpos (+ dy box-hheight))))
+ (result (let process-pedal ((remaining pedal-list)
+ (prev-x 0)
+ (stencils '())
+ (circled #f)
+ (space spacebeforedivider))
+ ;; Terminal condition of the recursion, return (final-x . stencil-list)
+ (if (null? remaining)
+ (cons (+ prev-x space) (reverse stencils))
- (case (car remaining)
- ((1 0 -1) ; Pedal up/neutral/down
- (let* ((p (car remaining))
- (stencil (make-filled-box-stencil
- (box-x-dimensions prev-x p space)
- (box-y-dimensions prev-x p space)))
- (pedal-stencil
- (if circled
- (oval-stencil stencil circle-thickness
- circle-x-padding circle-y-padding)
- stencil))
- (new-prev-x (+ prev-x space box-width)))
- (process-pedal (cdr remaining) new-prev-x
- (cons pedal-stencil stencils) #f space)))
- ((#\|) ; Divider line
- (let* ((xpos (+ prev-x space))
- (stencil (divider-stencil xpos))
- (new-prev-x (+ prev-x space)))
- (process-pedal (cdr remaining) new-prev-x
- (cons stencil stencils)
- circled spaceafterdivider)))
- ((#\o) ; Next pedal should be circled
- (process-pedal (cdr remaining) prev-x stencils #t space))
- (else
- (ly:warning "Unhandled entry in harp-pedal: ~a"
- (car remaining))
- (process-pedal (cdr remaining)
- prev-x stencils circled space))))))
- (final-x (car result))
- (stencils (cdr result)))
+ (case (car remaining)
+ ((1 0 -1) ; Pedal up/neutral/down
+ (let* ((p (car remaining))
+ (stencil (make-filled-box-stencil
+ (box-x-dimensions prev-x p space)
+ (box-y-dimensions prev-x p space)))
+ (pedal-stencil
+ (if circled
+ (oval-stencil stencil circle-thickness
+ circle-x-padding circle-y-padding)
+ stencil))
+ (new-prev-x (+ prev-x space box-width)))
+ (process-pedal (cdr remaining) new-prev-x
+ (cons pedal-stencil stencils) #f space)))
+ ((#\|) ; Divider line
+ (let* ((xpos (+ prev-x space))
+ (stencil (divider-stencil xpos))
+ (new-prev-x (+ prev-x space)))
+ (process-pedal (cdr remaining) new-prev-x
+ (cons stencil stencils)
+ circled spaceafterdivider)))
+ ((#\o) ; Next pedal should be circled
+ (process-pedal (cdr remaining) prev-x stencils #t space))
+ (else
+ (ly:warning "Unhandled entry in harp-pedal: ~a"
+ (car remaining))
+ (process-pedal (cdr remaining)
+ prev-x stencils circled space))))))
+ (final-x (car result))
+ (stencils (cdr result)))
;; Add the horizontal line and combine all stencils:
(box-stencil
- (apply ly:stencil-add
- (cons
- (make-line-stencil line-width 0 0 final-x 0)
- stencils))
- 0.0
- 0.0)))
+ (apply ly:stencil-add
+ (cons
+ (make-line-stencil line-width 0 0 final-x 0)
+ stencils))
+ 0.0
+ 0.0)))
;; Parse the harp pedal definition string into list of directions (-1/0/1), #\o and #\|
(define (harp-pedals-parse-string definition-string)
- "Parse a harp pedals diagram string and return a list containing 1, 0, -1, #\\o or #\\|"
+ "Parse a harp pedals diagram string and return a list containing 1, 0, -1, #\\o or #\\|"
(map (lambda (c)
- (case c
- ((#\^) 1)
- ((#\v) -1)
- ((#\-) 0)
- ((#\| #\o) c)
- (else c)))
- (string->list definition-string)))
+ (case c
+ ((#\^) 1)
+ ((#\v) -1)
+ ((#\-) 0)
+ ((#\| #\o) c)
+ (else c)))
+ (string->list definition-string)))
;; Analyze the pedal-list: Return (pedalcount . (divider positions))
(pedalcount 0)
(dividerpositions '()))
(if (null? pedals)
- (cons pedalcount (reverse dividerpositions))
+ (cons pedalcount (reverse dividerpositions))
- (case (car pedals)
- ((-1 0 1) (check (cdr pedals) (+ pedalcount 1) dividerpositions))
- ((#\|) (check (cdr pedals) pedalcount (cons pedalcount dividerpositions)))
- (else (check (cdr pedals) pedalcount dividerpositions))))))
+ (case (car pedals)
+ ((-1 0 1) (check (cdr pedals) (+ pedalcount 1) dividerpositions))
+ ((#\|) (check (cdr pedals) pedalcount (cons pedalcount dividerpositions)))
+ (else (check (cdr pedals) pedalcount dividerpositions))))))
;; Sanity checks, spit out warning if pedal-list violates the conventions
(let ((info (harp-pedal-info pedal-list)))
;; 7 pedals:
(if (not (equal? (car info) 7))
- (ly:warning "Harp pedal diagram contains ~a pedals rather than the usual 7." (car info)))
+ (ly:warning "Harp pedal diagram contains ~a pedals rather than the usual 7." (car info)))
;; One divider after third pedal:
(if (null? (cdr info))
- (ly:warning "Harp pedal diagram does not contain a divider (usually after third pedal).")
- (if (not (equal? (cdr info) '(3)))
- (ly:warning "Harp pedal diagram contains dividers at positions ~a. Normally, there is only one divider after the third pedal." (cdr info))))))
+ (ly:warning "Harp pedal diagram does not contain a divider (usually after third pedal).")
+ (if (not (equal? (cdr info) '(3)))
+ (ly:warning "Harp pedal diagram contains dividers at positions ~a. Normally, there is only one divider after the third pedal." (cdr info))))))
(define check-beam-quant
(lambda (posl posr)
(lambda (beam posns)
- "Check whether BEAM has POSL and POSR quants. POSL are (POSITION
-. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter)
+ "Check whether BEAM has POSL and POSR quants. POSL are (POSITION
+. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter)
"
- (let* ((thick (ly:grob-property beam 'beam-thickness))
- (layout (ly:grob-layout beam))
- (lthick (ly:output-def-lookup layout 'line-thickness))
- (staff-thick lthick) ; fixme.
- (quant->coord (lambda (p q)
- (if (= 2 (abs q))
- (+ p (/ q 4.0))
- (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
- (want-l (quant->coord (car posl) (cdr posl)))
- (want-r (quant->coord (car posr) (cdr posr)))
- (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
-
- (if (or (not (almost-equal want-l (car posns)))
- (not (almost-equal want-r (cdr posns))))
- (begin
- (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.")
- want-l want-r posns)
- (set! (ly:grob-property beam 'annotation)
- (format #f "(~S,~S)" want-l want-r))))
- posns))))
+ (let* ((thick (ly:grob-property beam 'beam-thickness))
+ (layout (ly:grob-layout beam))
+ (lthick (ly:output-def-lookup layout 'line-thickness))
+ (staff-thick lthick) ; fixme.
+ (quant->coord (lambda (p q)
+ (if (= 2 (abs q))
+ (+ p (/ q 4.0))
+ (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
+ (want-l (quant->coord (car posl) (cdr posl)))
+ (want-r (quant->coord (car posr) (cdr posr)))
+ (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
+
+ (if (or (not (almost-equal want-l (car posns)))
+ (not (almost-equal want-r (cdr posns))))
+ (begin
+ (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.")
+ want-l want-r posns)
+ (set! (ly:grob-property beam 'annotation)
+ (format #f "(~S,~S)" want-l want-r))))
+ posns))))
(define check-beam-slope-sign
(lambda (comparison)
(lambda (beam posns)
- "Check whether the slope of BEAM is correct wrt. COMPARISON."
- (let* ((slope-sign (- (cdr posns) (car posns)))
- (correct (comparison slope-sign 0)))
- (if (not correct)
- (begin
- (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.")
- (procedure-name comparison) slope-sign)
- (set! (ly:grob-property beam 'annotation)
- (format #f "~S 0" (procedure-name comparison))))
- (set! (ly:grob-property beam 'annotation) ""))
- posns))))
+ "Check whether the slope of BEAM is correct wrt. COMPARISON."
+ (let* ((slope-sign (- (cdr posns) (car posns)))
+ (correct (comparison slope-sign 0)))
+ (if (not correct)
+ (begin
+ (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.")
+ (procedure-name comparison) slope-sign)
+ (set! (ly:grob-property beam 'annotation)
+ (format #f "~S 0" (procedure-name comparison))))
+ (set! (ly:grob-property beam 'annotation) ""))
+ posns))))
(define-public (check-quant-callbacks l r)
(lambda (grob)
((check-beam-quant l r)
- grob
- (beam::place-broken-parts-individually grob))))
+ grob
+ (beam::place-broken-parts-individually grob))))
(define-public (check-slope-callbacks comparison)
(lambda (grob)
((check-beam-slope-sign comparison)
- grob
- (beam::place-broken-parts-individually grob))))
-
+ grob
+ (beam::place-broken-parts-individually grob))))
;; durations
(define-public (duration-log-factor lognum)
-"Given a logarithmic duration number, return the length of the duration,
+ "Given a logarithmic duration number, return the length of the duration,
as a number of whole notes."
(or (and (exact? lognum) (integer? lognum))
- (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
+ (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
(if (<= lognum 0)
- (ash 1 (- lognum))
- (/ (ash 1 lognum))))
+ (ash 1 (- lognum))
+ (/ (ash 1 lognum))))
(define-public (duration-dot-factor dotcount)
-"Given a count of the dots used to extend a musical duration, return
+ "Given a count of the dots used to extend a musical duration, return
the numeric factor by which they increase the duration."
(or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0))
- (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
+ (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
(- 2 (/ (ash 1 dotcount))))
(define-public (duration-length dur)
-"Return the overall length of a duration, as a number of whole
+ "Return the overall length of a duration, as a number of whole
notes. (Not to be confused with ly:duration-length, which returns a
less-useful moment object.)"
(ly:moment-main (ly:duration-length dur)))
(define-public (duration-visual dur)
-"Given a duration object, return the visual part of the duration (base
+ "Given a duration object, return the visual part of the duration (base
note length and dot count), in the form of a duration object with
non-visual scale factor 1."
(ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1))
(define-public (duration-visual-length dur)
-"Given a duration object, return the length of the visual part of the
+ "Given a duration object, return the length of the visual part of the
duration (base note length and dot count), as a number of whole notes."
(duration-length (duration-visual dur)))
"Toplevel book-part handler."
(define (add-bookpart book-part)
(ly:parser-define!
- parser 'toplevel-bookparts
- (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
+ parser 'toplevel-bookparts
+ (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
;; If toplevel scores have been found before this \bookpart,
;; add them first to a dedicated bookpart
(if (pair? (ly:parser-lookup parser 'toplevel-scores))
(begin
- (add-bookpart (ly:make-book-part
- (ly:parser-lookup parser 'toplevel-scores)))
- (ly:parser-define! parser 'toplevel-scores (list))))
+ (add-bookpart (ly:make-book-part
+ (ly:parser-lookup parser 'toplevel-scores)))
+ (ly:parser-define! parser 'toplevel-scores (list))))
(add-bookpart book-part))
(define-public (collect-scores-for-book parser score)
(define (music-property symbol)
(ly:music-property music symbol #f))
(cond ((music-property 'page-marker)
- ;; a page marker: set page break/turn permissions or label
+ ;; a page marker: set page break/turn permissions or label
(let ((label (music-property 'page-label)))
(if (symbol? label)
(score-handler (ly:make-page-label-marker label))))
'(line-break-permission page-break-permission
page-turn-permission)))
((not (music-property 'void))
- ;; a regular music expression: make a score with this music
- ;; void music is discarded
- (score-handler (scorify-music music parser)))))
+ ;; a regular music expression: make a score with this music
+ ;; void music is discarded
+ (score-handler (scorify-music music parser)))))
(define-public (collect-music-for-book parser music)
"Top-level music handler."
(collect-music-aux (lambda (score)
- (collect-scores-for-book parser score))
+ (collect-scores-for-book parser score))
parser
- music))
+ music))
(define-public (collect-book-music-for-book parser book music)
"Book music handler."
(collect-music-aux (lambda (score)
- (ly:book-add-score! book score))
+ (ly:book-add-score! book score))
parser
- music))
+ music))
(define-public (scorify-music music parser)
"Preprocess @var{music}."
bookoutput function"
(let ((book-output-suffix (paper-variable parser book 'output-suffix)))
(if (not (string? book-output-suffix))
- (ly:parser-lookup parser 'output-suffix)
- book-output-suffix)))
+ (ly:parser-lookup parser 'output-suffix)
+ book-output-suffix)))
(define-public current-outfile-name #f) ; for use by regression tests
;; the file-name concatenated with any potential output-suffix value
;; as the key to out internal a-list
(let* ((base-name (get-current-filename parser book))
- (output-suffix (get-current-suffix parser book))
- (alist-key (format #f "~a~a" base-name output-suffix))
- (counter-alist (ly:parser-lookup parser 'counter-alist))
- (output-count (assoc-get alist-key counter-alist 0))
- (result base-name))
+ (output-suffix (get-current-suffix parser book))
+ (alist-key (format #f "~a~a" base-name output-suffix))
+ (counter-alist (ly:parser-lookup parser 'counter-alist))
+ (output-count (assoc-get alist-key counter-alist 0))
+ (result base-name))
;; Allow all ASCII alphanumerics, including accents
(if (string? output-suffix)
(set! result
(define (print-book-with parser book process-procedure)
(let* ((paper (ly:parser-lookup parser '$defaultpaper))
- (layout (ly:parser-lookup parser '$defaultlayout))
- (outfile-name (get-outfile-name parser book)))
+ (layout (ly:parser-lookup parser '$defaultlayout))
+ (outfile-name (get-outfile-name parser book)))
(process-procedure book paper layout outfile-name)))
(define-public (print-book-with-defaults parser book)
;; Add a score to the current bookpart, book or toplevel
(define-public (add-score parser score)
- (cond
- ((ly:parser-lookup parser '$current-bookpart)
- ((ly:parser-lookup parser 'bookpart-score-handler)
- (ly:parser-lookup parser '$current-bookpart) score))
- ((ly:parser-lookup parser '$current-book)
- ((ly:parser-lookup parser 'book-score-handler)
- (ly:parser-lookup parser '$current-book) score))
- (else
- ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
+ (cond
+ ((ly:parser-lookup parser '$current-bookpart)
+ ((ly:parser-lookup parser 'bookpart-score-handler)
+ (ly:parser-lookup parser '$current-bookpart) score))
+ ((ly:parser-lookup parser '$current-book)
+ ((ly:parser-lookup parser 'book-score-handler)
+ (ly:parser-lookup parser '$current-book) score))
+ (else
+ ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
(define-public paper-variable
(let
((get-papers
- (lambda (parser book)
- (append (if (and book (ly:output-def? (ly:book-paper book)))
- (list (ly:book-paper book))
- '())
- (ly:parser-lookup parser '$papers)
- (list (ly:parser-lookup parser '$defaultpaper))))))
+ (lambda (parser book)
+ (append (if (and book (ly:output-def? (ly:book-paper book)))
+ (list (ly:book-paper book))
+ '())
+ (ly:parser-lookup parser '$papers)
+ (list (ly:parser-lookup parser '$defaultpaper))))))
(make-procedure-with-setter
(lambda (parser book symbol)
(any (lambda (p) (ly:output-def-lookup p symbol #f))
- (get-papers parser book)))
+ (get-papers parser book)))
(lambda (parser book symbol value)
(ly:output-def-set-variable!
- (car (get-papers parser book))
- symbol value)))))
+ (car (get-papers parser book))
+ symbol value)))))
(define-public (add-text parser text)
(add-score parser (list text)))
(define-public (add-music parser music)
(collect-music-aux (lambda (score)
- (add-score parser score))
+ (add-score parser score))
parser
- music))
+ music))
(define-public (context-mod-from-music parser music)
(let ((warn #t) (mods (ly:make-context-mod)))
(let loop ((m music))
(if (music-is-of-type? m 'layout-instruction-event)
- (let ((symbol (ly:music-property m 'symbol)))
- (ly:add-context-mod
- mods
- (case (ly:music-property m 'name)
- ((PropertySet)
- (list 'assign
- symbol
- (ly:music-property m 'value)))
- ((PropertyUnset)
- (list 'unset symbol))
- ((OverrideProperty)
- (cons* 'push
- symbol
- (ly:music-property m 'grob-value)
+ (let ((symbol (ly:music-property m 'symbol)))
+ (ly:add-context-mod
+ mods
+ (case (ly:music-property m 'name)
+ ((PropertySet)
+ (list 'assign
+ symbol
+ (ly:music-property m 'value)))
+ ((PropertyUnset)
+ (list 'unset symbol))
+ ((OverrideProperty)
+ (cons* 'push
+ symbol
+ (ly:music-property m 'grob-value)
(cond
((ly:music-property m 'grob-property #f) => list)
(else
(ly:music-property m 'grob-property-path)))))
((RevertProperty)
- (cons* 'pop
- symbol
+ (cons* 'pop
+ symbol
(cond
((ly:music-property m 'grob-property #f) => list)
(else
(ly:music-property m 'grob-property-path))))))))
- (case (ly:music-property m 'name)
- ((ApplyContext)
- (ly:add-context-mod mods
- (list 'apply
- (ly:music-property m 'procedure))))
- ((ContextSpeccedMusic)
- (loop (ly:music-property m 'element)))
- (else
- (let ((callback (ly:music-property m 'elements-callback)))
- (if (procedure? callback)
- (for-each loop (callback m))
- (if (and warn (ly:duration? (ly:music-property m 'duration)))
- (begin
- (ly:music-warning
- music
- (_ "Music unsuitable for context-mod"))
- (set! warn #f)))))))))
+ (case (ly:music-property m 'name)
+ ((ApplyContext)
+ (ly:add-context-mod mods
+ (list 'apply
+ (ly:music-property m 'procedure))))
+ ((ContextSpeccedMusic)
+ (loop (ly:music-property m 'element)))
+ (else
+ (let ((callback (ly:music-property m 'elements-callback)))
+ (if (procedure? callback)
+ (for-each loop (callback m))
+ (if (and warn (ly:duration? (ly:music-property m 'duration)))
+ (begin
+ (ly:music-warning
+ music
+ (_ "Music unsuitable for context-mod"))
+ (set! warn #f)))))))))
mods))
(define-public (context-defs-from-music parser output-def music)
;; context modification results in a reasonably recognizable
;; error.
(if (music-is-of-type? m 'layout-instruction-event)
- (ly:add-context-mod
- mods
- (case (ly:music-property m 'name)
- ((PropertySet)
- (list 'assign
- (ly:music-property m 'symbol)
- (ly:music-property m 'value)))
- ((PropertyUnset)
- (list 'unset
- (ly:music-property m 'symbol)))
- ((OverrideProperty)
- (cons* 'push
- (ly:music-property m 'symbol)
- (ly:music-property m 'grob-value)
+ (ly:add-context-mod
+ mods
+ (case (ly:music-property m 'name)
+ ((PropertySet)
+ (list 'assign
+ (ly:music-property m 'symbol)
+ (ly:music-property m 'value)))
+ ((PropertyUnset)
+ (list 'unset
+ (ly:music-property m 'symbol)))
+ ((OverrideProperty)
+ (cons* 'push
+ (ly:music-property m 'symbol)
+ (ly:music-property m 'grob-value)
(cond
((ly:music-property m 'grob-property #f) => list)
(else
(ly:music-property m 'grob-property-path)))))
- ((RevertProperty)
- (cons* 'pop
- (ly:music-property m 'symbol)
+ ((RevertProperty)
+ (cons* 'pop
+ (ly:music-property m 'symbol)
(cond
((ly:music-property m 'grob-property #f) => list)
(else
(ly:music-property m 'grob-property-path)))))))
- (case (ly:music-property m 'name)
- ((ApplyContext)
- (ly:add-context-mod mods
- (list 'apply
- (ly:music-property m 'procedure))))
- ((ContextSpeccedMusic)
- ;; Use let* here to let defs catch up with modifications
- ;; to the context defs made in the recursion
- (let* ((mods (loop (ly:music-property m 'element)
- (ly:make-context-mod)))
- (defs (ly:output-find-context-def
- output-def (ly:music-property m 'context-type))))
- (if (null? defs)
- (ly:music-warning
- music
- (ly:format (_ "Cannot find context-def \\~a")
- (ly:music-property m 'context-type)))
- (for-each
- (lambda (entry)
- (ly:output-def-set-variable!
- output-def (car entry)
- (ly:context-def-modify (cdr entry) mods)))
- defs))))
- (else
- (let ((callback (ly:music-property m 'elements-callback)))
- (if (procedure? callback)
- (fold loop mods (callback m))
- (if (and warn (ly:duration? (ly:music-property m 'duration)))
- (begin
- (ly:music-warning
- music
- (_ "Music unsuitable for output-def"))
- (set! warn #f))))))))
+ (case (ly:music-property m 'name)
+ ((ApplyContext)
+ (ly:add-context-mod mods
+ (list 'apply
+ (ly:music-property m 'procedure))))
+ ((ContextSpeccedMusic)
+ ;; Use let* here to let defs catch up with modifications
+ ;; to the context defs made in the recursion
+ (let* ((mods (loop (ly:music-property m 'element)
+ (ly:make-context-mod)))
+ (defs (ly:output-find-context-def
+ output-def (ly:music-property m 'context-type))))
+ (if (null? defs)
+ (ly:music-warning
+ music
+ (ly:format (_ "Cannot find context-def \\~a")
+ (ly:music-property m 'context-type)))
+ (for-each
+ (lambda (entry)
+ (ly:output-def-set-variable!
+ output-def (car entry)
+ (ly:context-def-modify (cdr entry) mods)))
+ defs))))
+ (else
+ (let ((callback (ly:music-property m 'elements-callback)))
+ (if (procedure? callback)
+ (fold loop mods (callback m))
+ (if (and warn (ly:duration? (ly:music-property m 'duration)))
+ (begin
+ (ly:music-warning
+ music
+ (_ "Music unsuitable for output-def"))
+ (set! warn #f))))))))
mods)))
(define-public (uniqued-alist alist acc)
(if (null? alist) acc
(if (assoc (caar alist) acc)
- (uniqued-alist (cdr alist) acc)
- (uniqued-alist (cdr alist) (cons (car alist) acc)))))
+ (uniqued-alist (cdr alist) acc)
+ (uniqued-alist (cdr alist) (cons (car alist) acc)))))
(define-public (alist<? x y)
(string<? (symbol->string (car x))
- (symbol->string (car y))))
+ (symbol->string (car y))))
(define (map-alist-vals func list)
"map FUNC over the vals of LIST, leaving the keys."
(if (null? list)
'()
(cons (cons (caar list) (func (cdar list)))
- (map-alist-vals func (cdr list)))))
+ (map-alist-vals func (cdr list)))))
(define (map-alist-keys func list)
"map FUNC over the keys of an alist LIST, leaving the vals."
(if (null? list)
'()
(cons (cons (func (caar list)) (cdar list))
- (map-alist-keys func (cdr list)))))
+ (map-alist-keys func (cdr list)))))
(define-public (first-member members lst)
"Return first successful member (of member) from @var{members} in
(if (null? alist)
'()
(cons (caar alist)
- (cons (cdar alist)
- (flatten-alist (cdr alist))))))
+ (cons (cdar alist)
+ (flatten-alist (cdr alist))))))
(define (assoc-remove key alist)
"Remove key (and its corresponding value) from an alist.
@code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
@code{((a . -1) (b . 2) (c . 3) (d . 4)}
@end example"
- (define (map-selected-alist-keys-helper function key alist)
- (map
+ (define (map-selected-alist-keys-helper function key alist)
+ (map
(lambda (pair)
(if (equal? key (car pair))
(cons key (function (cdr pair)))
pair))
alist))
- (if (null? keys)
- alist
- (map-selected-alist-keys
- function
- (cdr keys)
- (map-selected-alist-keys-helper function (car keys) alist))))
+ (if (null? keys)
+ alist
+ (map-selected-alist-keys
+ function
+ (cdr keys)
+ (map-selected-alist-keys-helper function (car keys) alist))))
;;;;;;;;;;;;;;;;
;; vector
(define (helper todo acc-vector k)
(if (null? todo)
- acc-vector
- (begin
- (if (< k 0)
- (set! k (+ n k)))
+ acc-vector
+ (begin
+ (if (< k 0)
+ (set! k (+ n k)))
- (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
- (helper (cdr todo) acc-vector (1- k)))))
+ (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
+ (helper (cdr todo) acc-vector (1- k)))))
(helper lst (make-vector n '()) (1- n)))
(fold-right
(lambda (elem prev)
- (if (pair? prev)
- (cons elem (cons intermediate prev))
- (list elem)))
- '() lst))
+ (if (pair? prev)
+ (cons elem (cons intermediate prev))
+ (list elem)))
+ '() lst))
(define-public (filtered-map proc lst)
(filter
(reverse!
(fold (lambda (x acc)
- (if (null? acc)
- (list x)
- (if (equal? x (car acc))
- acc
- (cons x acc))))
- '() lst) '()))
+ (if (null? acc)
+ (list x)
+ (if (equal? x (car acc))
+ acc
+ (cons x acc))))
+ '() lst) '()))
(define (split-at-predicate pred lst)
"Split LST into two lists at the first element that returns #f for
(define-public (offset-add a b)
(cons (+ (car a) (car b))
- (+ (cdr a) (cdr b))))
+ (+ (cdr a) (cdr b))))
(define-public (offset-flip-y o)
(cons (car o) (- (cdr o))))
(define-public (offset-scale o scale)
(cons (* (car o) scale)
- (* (cdr o) scale)))
+ (* (cdr o) scale)))
(define-public (ly:list->offsets accum coords)
(if (null? coords)
accum
(cons (cons (car coords) (cadr coords))
- (ly:list->offsets accum (cddr coords)))))
+ (ly:list->offsets accum (cddr coords)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; intervals
(define-public (ordered-cons a b)
(cons (min a b)
- (max a b)))
+ (max a b)))
(define-public (interval-bound interval dir)
((if (= dir RIGHT) cdr car) interval))
right (@var{dir}=+1)."
(* (+ (interval-start interval) (interval-end interval)
- (* dir (- (interval-end interval) (interval-start interval))))
+ (* dir (- (interval-end interval) (interval-start interval))))
0.5))
(define-public (interval-center x)
(define-public (interval-scale iv factor)
(cons (* (car iv) factor)
- (* (cdr iv) factor)))
+ (* (cdr iv) factor)))
(define-public (interval-widen iv amount)
(cons (- (car iv) amount)
- (+ (cdr iv) amount)))
+ (+ (cdr iv) amount)))
(define-public (interval-empty? iv)
- (> (car iv) (cdr iv)))
+ (> (car iv) (cdr iv)))
(define-public (interval-union i1 i2)
(cons
- (min (car i1) (car i2))
- (max (cdr i1) (cdr i2))))
+ (min (car i1) (car i2))
+ (max (cdr i1) (cdr i2))))
(define-public (interval-intersection i1 i2)
- (cons
- (max (car i1) (car i2))
- (min (cdr i1) (cdr i2))))
+ (cons
+ (max (car i1) (car i2))
+ (min (cdr i1) (cdr i2))))
(define-public (interval-sane? i)
(not (or (nan? (car i))
- (inf? (car i))
- (nan? (cdr i))
- (inf? (cdr i))
- (> (car i) (cdr i)))))
+ (inf? (car i))
+ (nan? (cdr i))
+ (inf? (cdr i))
+ (> (car i) (cdr i)))))
(define-public (add-point interval p)
(cons (min (interval-start interval) p)
(define (coord-operation operator operand coordinate)
(if (pair? operand)
- (cons (operator (coord-x operand) (coord-x coordinate))
- (operator (coord-y operand) (coord-y coordinate)))
- (cons (operator operand (coord-x coordinate))
- (operator operand (coord-y coordinate)))))
+ (cons (operator (coord-x operand) (coord-x coordinate))
+ (operator (coord-y operand) (coord-y coordinate)))
+ (cons (operator operand (coord-x coordinate))
+ (operator operand (coord-y coordinate)))))
(define (coord-apply function coordinate)
(if (pair? function)
- (cons
- ((coord-x function) (coord-x coordinate))
- ((coord-y function) (coord-y coordinate)))
- (cons
- (function (coord-x coordinate))
- (function (coord-y coordinate)))))
+ (cons
+ ((coord-x function) (coord-x coordinate))
+ ((coord-y function) (coord-y coordinate)))
+ (cons
+ (function (coord-x coordinate))
+ (function (coord-y coordinate)))))
(define-public (coord-translate coordinate amount)
(coord-operation + amount coordinate))
(define-public (coord-rotate coordinate degrees-in-radians)
(let*
- ((coordinate
- (cons
- (exact->inexact (coord-x coordinate))
- (exact->inexact (coord-y coordinate))))
- (radius
- (sqrt
- (+ (* (coord-x coordinate) (coord-x coordinate))
- (* (coord-y coordinate) (coord-y coordinate)))))
- (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
- (cons
+ ((coordinate
+ (cons
+ (exact->inexact (coord-x coordinate))
+ (exact->inexact (coord-y coordinate))))
+ (radius
+ (sqrt
+ (+ (* (coord-x coordinate) (coord-x coordinate))
+ (* (coord-y coordinate) (coord-y coordinate)))))
+ (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
+ (cons
(* radius (cos (+ angle degrees-in-radians)))
(* radius (sin (+ angle degrees-in-radians))))))
(define-public (ellipse-radius x-radius y-radius angle)
(/
- (* x-radius y-radius)
- (sqrt
- (+ (* (expt y-radius 2)
- (* (cos angle) (cos angle)))
- (* (expt x-radius 2)
- (* (sin angle) (sin angle)))))))
+ (* x-radius y-radius)
+ (sqrt
+ (+ (* (expt y-radius 2)
+ (* (cos angle) (cos angle)))
+ (* (expt x-radius 2)
+ (* (sin angle) (sin angle)))))))
(define-public (polar->rectangular radius angle-in-degrees)
"Return polar coordinates (@var{radius}, @var{angle-in-degrees})
as rectangular coordinates @ode{(x-length . y-length)}."
(let ((complex (make-polar
- radius
- (degrees->radians angle-in-degrees))))
- (cons
- (real-part complex)
- (imag-part complex))))
+ radius
+ (degrees->radians angle-in-degrees))))
+ (cons
+ (real-part complex)
+ (imag-part complex))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string
(define-public (string-endswith s suffix)
(equal? suffix (substring s
- (max 0 (- (string-length s) (string-length suffix)))
- (string-length s))))
+ (max 0 (- (string-length s) (string-length suffix)))
+ (string-length s))))
(define-public (string-startswith s prefix)
(equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
((= i 0) "o")
((< i 0) (string-append "n" (string-encode-integer (- i))))
(else (string-append
- (make-string 1 (integer->char (+ 65 (modulo i 26))))
- (string-encode-integer (quotient i 26))))))
+ (make-string 1 (integer->char (+ 65 (modulo i 26))))
+ (string-encode-integer (quotient i 26))))))
(define (number->octal-string x)
(let* ((n (inexact->exact x))
(define-public (ly:number-pair->string c)
(string-append (ly:number->string (car c)) " "
- (ly:number->string (cdr c))))
+ (ly:number->string (cdr c))))
(define-public (dir-basename file . rest)
"Strip suffixes in @var{rest}, but leave directory component for
@var{file}."
(define (inverse-basename x y) (basename y x))
(simple-format #f "~a/~a" (dirname file)
- (fold inverse-basename file rest)))
+ (fold inverse-basename file rest)))
(define-public (write-me message x)
"Return @var{x}. Display @var{message} and write @var{x}.
"Create new list, inserting @var{between} between elements of @var{lst}."
(define (conc x y )
(if (eq? y #f)
- (list x)
- (cons x (cons between y))))
+ (list x)
+ (cons x (cons between y))))
(fold-right conc #f lst))
(define-public (string-regexp-substitute a b str)
(define (notice match)
(set! matches (cons (substring (match:string match)
- end-of-prev-match
- (match:start match))
- matches))
+ end-of-prev-match
+ (match:start match))
+ matches))
(set! end-of-prev-match (match:end match)))
(regexp-substitute/global #f regex str notice 'post)
matches
(cons (substring str end-of-prev-match (string-length str)) matches)))
- (reverse matches))
+ (reverse matches))
;;;;;;;;;;;;;;;;
;; other
(if (<= end start)
start
(let* ((compare (quotient (+ start end) 2))
- (get-val (getter compare)))
- (cond
- ((< target-val get-val)
- (set! end (1- compare)))
- ((< get-val target-val)
- (set! start (1+ compare))))
- (binary-search start end getter target-val))))
+ (get-val (getter compare)))
+ (cond
+ ((< target-val get-val)
+ (set! end (1- compare)))
+ ((< get-val target-val)
+ (set! start (1+ compare))))
+ (binary-search start end getter target-val))))
(define-public (car< a b)
(< (car a) (car b)))
print a warning and set an optional @var{default}."
(let* ((unavailable? (lambda (sym)
(not (module-defined? module sym))))
- (sym-unavailable
+ (sym-unavailable
(filter
unavailable?
(filter symbol? (flatten-list symbol)))))
(eval symbol module)
(let* ((def (and (pair? default) (car default))))
(ly:programming-error
- "cannot evaluate ~S in module ~S, setting to ~S"
- (object->string symbol)
- (object->string module)
- (object->string def))
+ "cannot evaluate ~S in module ~S, setting to ~S"
+ (object->string symbol)
+ (object->string module)
+ (object->string def))
def))))
;;
;;
(define-public (scm->string val)
(if (and (procedure? val)
- (symbol? (procedure-name val)))
+ (symbol? (procedure-name val)))
(symbol->string (procedure-name val))
(string-append
(if (self-evaluating? val)
- (if (string? val)
- "\""
- "")
- "'")
+ (if (string? val)
+ "\""
+ "")
+ "'")
(call-with-output-string (lambda (port) (display val port)))
(if (string? val)
- "\""
- ""))))
+ "\""
+ ""))))
(define-public (!= lst r)
(not (= lst r)))
(if (string? font)
(string-downcase font)
(let* ((font-name (ly:font-name font))
- (full-name (if font-name font-name (ly:font-file-name font))))
- (string-downcase full-name))))
+ (full-name (if font-name font-name (ly:font-file-name font))))
+ (string-downcase full-name))))
(define-public (modified-font-metric-font-scaling font)
(let* ((designsize (ly:font-design-size font))
- (magnification (* (ly:font-magnification font)))
- (scaling (* magnification designsize)))
+ (magnification (* (ly:font-magnification font)))
+ (scaling (* magnification designsize)))
(debugf "scaling:~S\n" scaling)
(debugf "magnification:~S\n" magnification)
(debugf "design:~S\n" designsize)
(define-public (version-not-seen-message input-file-name)
(ly:warning-located
- (ly:format "~a:1" input-file-name)
- (_ "no \\version statement found, please add~afor future compatibility")
- (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
+ (ly:format "~a:1" input-file-name)
+ (_ "no \\version statement found, please add~afor future compatibility")
+ (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
((null? a) (cons #f (car b)))
((null? b) (cons (car a) #f))
((not ((if ci char-ci=? char=?) (car a) (car b)))
- (cons (car a) (car b)))
+ (cons (car a) (car b)))
(else (find-mismatch (cdr a) (cdr b))))))
(define (ly:string-generic-<? a b ci)
(let ((mismatch (first-diff-chars a b ci)))
(cond ((and mismatch (car mismatch) (cdr mismatch))
- ((if ci ly:char-ci<? ly:char<?)
- (car mismatch) (cdr mismatch)))
+ ((if ci ly:char-ci<? ly:char<?)
+ (car mismatch) (cdr mismatch)))
((and mismatch (cdr mismatch)) #t)
(else #f))))
ignore @var{thunk} and instead just reinitialize all recorded
variables to their value after the initial call of @var{thunk}."
-;; We need to save the variables of the current module along with
-;; their values: functions defined in the module might refer to the
-;; variables.
+ ;; We need to save the variables of the current module along with
+ ;; their values: functions defined in the module might refer to the
+ ;; variables.
-;; The entries in lilypond-declarations consist of a cons* consisting
-;; of symbol, variable, and value. Variables defined with
-;; define-session have the symbol set to #f.
+ ;; The entries in lilypond-declarations consist of a cons* consisting
+ ;; of symbol, variable, and value. Variables defined with
+ ;; define-session have the symbol set to #f.
(if (ly:undead? lilypond-declarations)
(begin
;; be longer than 48 characters per line.
(anti-alias-factor 1
-"Render at higher resolution (using given factor)
+ "Render at higher resolution (using given factor)
and scale down result to prevent jaggies in
PNG images.")
(aux-files
- #t
-"Create .tex, .texi, .count files in the
+ #t
+ "Create .tex, .texi, .count files in the
EPS backend.")
(backend
- ps
-"Select backend. Possible values: 'eps, 'null,
+ ps
+ "Select backend. Possible values: 'eps, 'null,
'ps, 'scm, 'socket, 'svg.")
(check-internal-types
- #f
-"Check every property assignment for types.")
+ #f
+ "Check every property assignment for types.")
(clip-systems
- #f
-"Generate cut-out snippets of a score.")
+ #f
+ "Generate cut-out snippets of a score.")
(datadir
- #f
-"LilyPond prefix for data files (read-only).")
+ #f
+ "LilyPond prefix for data files (read-only).")
(debug-gc
- #f
-"Dump memory debugging statistics.")
+ #f
+ "Dump memory debugging statistics.")
(debug-gc-assert-parsed-dead
- #f
-"For memory debugging: Ensure that all
+ #f
+ "For memory debugging: Ensure that all
references to parsed objects are dead. This is
an internal option, and is switched on
automatically for `-ddebug-gc'.")
(debug-lexer
- #f
-"Debug the flex lexer.")
+ #f
+ "Debug the flex lexer.")
(debug-page-breaking-scoring
- #f
-"Dump scores for many different page breaking
+ #f
+ "Dump scores for many different page breaking
configurations.")
(debug-parser
- #f
-"Debug the bison parser.")
+ #f
+ "Debug the bison parser.")
(debug-property-callbacks
- #f
-"Debug cyclic callback chains.")
+ #f
+ "Debug cyclic callback chains.")
(debug-skylines
- #f
-"Debug skylines.")
+ #f
+ "Debug skylines.")
(delete-intermediate-files
- #t
-"Delete unusable, intermediate PostScript files.")
+ #t
+ "Delete unusable, intermediate PostScript files.")
(dump-profile
- #f
-"Dump memory and time information for each file.")
+ #f
+ "Dump memory and time information for each file.")
(dump-cpu-profile
- #f
-"Dump timing information (system-dependent).")
+ #f
+ "Dump timing information (system-dependent).")
(dump-signatures
- #f
-"Dump output signatures of each system. Used for
+ #f
+ "Dump output signatures of each system. Used for
regression testing.")
(eps-box-padding
- #f
-"Pad left edge of the output EPS bounding box by
+ #f
+ "Pad left edge of the output EPS bounding box by
given amount (in mm).")
(gs-load-fonts
- #f
-"Load fonts via Ghostscript.")
+ #f
+ "Load fonts via Ghostscript.")
(gs-load-lily-fonts
- #f
-"Load only LilyPond fonts via Ghostscript.")
+ #f
+ "Load only LilyPond fonts via Ghostscript.")
(gui
- #f
-"Run LilyPond from a GUI and redirect stderr to
+ #f
+ "Run LilyPond from a GUI and redirect stderr to
a log file.")
(help
- #f
-"Show this help.")
+ #f
+ "Show this help.")
(include-book-title-preview
- #t
-"Include book titles in preview images.")
+ #t
+ "Include book titles in preview images.")
(include-eps-fonts
- #t
-"Include fonts in separate-system EPS files.")
+ #t
+ "Include fonts in separate-system EPS files.")
(include-settings
- #f
-"Include file for global settings, included before the score is processed.")
+ #f
+ "Include file for global settings, included before the score is processed.")
(job-count
- #f
-"Process in parallel, using the given number of
+ #f
+ "Process in parallel, using the given number of
jobs.")
(log-file
- #f
-"If string FOO is given as argument, redirect
+ #f
+ "If string FOO is given as argument, redirect
output to log file `FOO.log'.")
(max-markup-depth
- 1024
-"Maximum depth for the markup tree. If a markup has more levels,
+ 1024
+ "Maximum depth for the markup tree. If a markup has more levels,
assume it will not terminate on its own, print a warning and return a
null markup instead.")
(midi-extension ,(if (eq? PLATFORM 'windows)
"mid"
"midi")
-"Set the default file extension for MIDI output
+ "Set the default file extension for MIDI output
file to given string.")
(music-strings-to-paths
- #f
-"Convert text strings to paths when glyphs belong
+ #f
+ "Convert text strings to paths when glyphs belong
to a music font.")
(point-and-click
- #t
-"Add point & click links to PDF output.")
+ #t
+ "Add point & click links to PDF output.")
(paper-size
- "a4"
-"Set default paper size.")
+ "a4"
+ "Set default paper size.")
(pixmap-format
- "png16m"
-"Set GhostScript's output format for pixel images.")
+ "png16m"
+ "Set GhostScript's output format for pixel images.")
(preview
- #f
-"Create preview images also.")
+ #f
+ "Create preview images also.")
(print-pages
- #t
-"Print pages in the normal way.")
+ #t
+ "Print pages in the normal way.")
(protected-scheme-parsing
- #t
-"Continue when errors in inline scheme are caught
+ #t
+ "Continue when errors in inline scheme are caught
in the parser. If #f, halt on errors and print
a stack trace.")
(profile-property-accesses
- #f
-"Keep statistics of get_property() calls.")
+ #f
+ "Keep statistics of get_property() calls.")
(resolution
- 101
-"Set resolution for generating PNG pixmaps to
+ 101
+ "Set resolution for generating PNG pixmaps to
given value (in dpi).")
(read-file-list
- #f
-"Specify name of a file which contains a list of
+ #f
+ "Specify name of a file which contains a list of
input files to be processed.")
(relative-includes
- #f
-"When processing an \\include command, look for
+ #f
+ "When processing an \\include command, look for
the included file relative to the current file\
\n(instead of the root file)")
(safe
- #f
-"Run in safer mode.")
+ #f
+ "Run in safer mode.")
(separate-log-files
- #f
-"For input files `FILE1.ly', `FILE2.ly', ...
+ #f
+ "For input files `FILE1.ly', `FILE2.ly', ...
output log data to files `FILE1.log',
`FILE2.log', ...")
(show-available-fonts
- #f
-"List available font names.")
+ #f
+ "List available font names.")
(strict-infinity-checking
- #f
-"Force a crash on encountering Inf and NaN
+ #f
+ "Force a crash on encountering Inf and NaN
floating point exceptions.")
(strip-output-dir
- #t
-"Don't use directories from input files while
+ #t
+ "Don't use directories from input files while
constructing output file names.")
(svg-woff
- #f
-"Use woff font files in SVG backend.")
+ #f
+ "Use woff font files in SVG backend.")
(trace-memory-frequency
- #f
-"Record Scheme cell usage this many times per
+ #f
+ "Record Scheme cell usage this many times per
second. Dump results to `FILE.stacks' and
`FILE.graph'.")
(trace-scheme-coverage
- #f
-"Record coverage of Scheme files in `FILE.cov'.")
+ #f
+ "Record coverage of Scheme files in `FILE.cov'.")
(verbose ,(ly:verbose-output?)
-"Verbose output, i.e. loglevel at least DEBUG (read-only).")
+ "Verbose output, i.e. loglevel at least DEBUG (read-only).")
(warning-as-error
- #f
-"Change all warning and programming_error
+ #f
+ "Change all warning and programming_error
messages into errors.")
))
(scm clip-region)
(scm memory-trace)
(scm coverage)
- (scm safe-utility-defs))
+ (scm safe-utility-defs))
(define-public _ gettext)
;;; There are new modules defined in Guile V2.0 which we need to use.
;;
(cond
- ((guile-v2)
- (ly:debug (_ "Using (ice-9 curried-definitions) module\n"))
- (use-modules (ice-9 curried-definitions)))
- (else
- (ly:debug (_ "Guile 1.8\n"))))
+ ((guile-v2)
+ (ly:debug (_ "Using (ice-9 curried-definitions) module\n"))
+ (use-modules (ice-9 curried-definitions)))
+ (else
+ (ly:debug (_ "Guile 1.8\n"))))
;; TODO add in modules for V1.8.7 deprecated in V2.0 and integrated
;; into Guile base code, like (ice-9 syncase).
(if (string-index x #\\)
x
(string-regexp-substitute
- "//*" "/"
- (string-regexp-substitute "\\\\" "/" x))))
+ "//*" "/"
+ (string-regexp-substitute "\\\\" "/" x))))
(define-public (ly-getcwd)
(if (eq? PLATFORM 'windows)
"x11-color.scm"))
;; - Files to be loaded last
(define init-scheme-files-tail
-;; - must be after everything has been defined
+ ;; - must be after everything has been defined
'("safe-lily.scm"))
;;
;; Now construct the load list
(define-public guile-predicates
`((,hash-table? . "hash table")
- ))
+ ))
(define-public lilypond-scheme-predicates
`((,boolean-or-symbol? . "boolean or symbol")
(lambda (a b)
(< (object-address (car a))
(object-address (car b))))))
- (out-file-name (string-append
- "gcstat-" (number->string gc-protect-stat-count)
- ".scm"))
- (outfile (open-file out-file-name "w")))
+ (out-file-name (string-append
+ "gcstat-" (number->string gc-protect-stat-count)
+ ".scm"))
+ (outfile (open-file out-file-name "w")))
(set! gc-dumping #t)
(ly:progress "Dumping GC statistics ~a...\n" out-file-name)
(for-each (lambda (y)
(ly:set-option 'debug-gc-assert-parsed-dead #t)
(gc)
(ly:set-option 'debug-gc-assert-parsed-dead #f)
- (for-each
- (lambda (x)
- (if (not (hashq-ref gc-zombies x))
- (begin
- (ly:programming-error "Parsed object should be dead: ~a" x)
- (hashq-set! gc-zombies x #t))))
- (ly:parsed-undead-list!))
+ (for-each
+ (lambda (x)
+ (if (not (hashq-ref gc-zombies x))
+ (begin
+ (ly:programming-error "Parsed object should be dead: ~a" x)
+ (hashq-set! gc-zombies x #t))))
+ (ly:parsed-undead-list!))
(set! stats (gc-live-object-stats))
(ly:progress "Dumping live object statistics.\n")
(dump-live-object-stats outfile)))
(define (helper count acc)
(if (> count 0)
(let* ((pid (primitive-fork)))
- (if (= pid 0)
- (1- count)
- (helper (1- count) (cons pid acc))))
+ (if (= pid 0)
+ (1- count)
+ (helper (1- count) (cons pid acc))))
acc))
(helper count '()))
(begin (ly:set-option
'log-file (format #f "~a-~a"
(ly:get-option 'log-file) joblist))
- (set! files (vector-ref split-todo joblist)))
+ (set! files (vector-ref split-todo joblist)))
(begin (ly:progress "\nForking into jobs: ~a\n" joblist)
(for-each
(lambda (pid)
(if (not (= stat 0))
(set! errors
(acons (list-element-index joblist pid)
- stat errors)))))
+ stat errors)))))
joblist)
(for-each
(lambda (x)
(ly:message
(_ "logfile ~a (exit ~a):\n~a")
logfile (status:exit-val state) tail))))
- errors)
- (if (pair? errors)
- (ly:error "Children ~a exited with errors."
- (map car errors)))
- ;; must overwrite individual entries
- (if (ly:get-option 'dump-profile)
- (dump-profile "lily-run-total"
- '(0 0) (profile-measurements)))
- (if (null? errors)
- (ly:exit 0 #f)
- (ly:exit 1 #f))))))
+ errors)
+ (if (pair? errors)
+ (ly:error "Children ~a exited with errors."
+ (map car errors)))
+ ;; must overwrite individual entries
+ (if (ly:get-option 'dump-profile)
+ (dump-profile "lily-run-total"
+ '(0 0) (profile-measurements)))
+ (if (null? errors)
+ (ly:exit 0 #f)
+ (ly:exit 1 #f))))))
(if (string-or-symbol? (ly:get-option 'log-file))
(ly:stderr-redirect (format #f "~a.log" (ly:get-option 'log-file)) "w"))
;; report errors.
(defmacro define-ly-syntax-simple (args . body)
`(define-public ,(cons* (car args)
- 'parser
- 'location
- (cdr args))
+ 'parser
+ 'location
+ (cdr args))
(let ((m ,(cons 'begin body)))
(set! (ly:music-property m 'origin) location)
m)))
;; fallback.
(define-ly-syntax (music-function parser loc fun args . rest)
(let* ((sig (ly:music-function-signature fun))
- (pred (if (pair? (car sig)) (caar sig) (car sig)))
- (good (proper-list? args))
- (m (and good (apply (ly:music-function-extract fun)
- parser loc (reverse! args rest)))))
+ (pred (if (pair? (car sig)) (caar sig) (car sig)))
+ (good (proper-list? args))
+ (m (and good (apply (ly:music-function-extract fun)
+ parser loc (reverse! args rest)))))
(if (and good (pred m))
- (begin
- (if (ly:music? m)
- (set! (ly:music-property m 'origin) loc))
- m)
- (begin
- (if good
- (ly:parser-error parser
- (format #f (_ "~a function cannot return ~a")
- (type-name pred) m)
- loc))
- (and (pair? (car sig)) (cdar sig))))))
+ (begin
+ (if (ly:music? m)
+ (set! (ly:music-property m 'origin) loc))
+ m)
+ (begin
+ (if good
+ (ly:parser-error parser
+ (format #f (_ "~a function cannot return ~a")
+ (type-name pred) m)
+ loc))
+ (and (pair? (car sig)) (cdar sig))))))
(define-ly-syntax (argument-error parser location n pred arg)
(ly:parser-error
parser
(format #f
- (_ "wrong type for argument ~a. Expecting ~a, found ~s")
- n (type-name pred) arg)
+ (_ "wrong type for argument ~a. Expecting ~a, found ~s")
+ n (type-name pred) arg)
location))
(define-ly-syntax-simple (void-music)
(define-ly-syntax-simple (event-chord mlist)
(make-music 'EventChord
- 'elements mlist))
+ 'elements mlist))
(define-ly-syntax-simple (unrelativable-music mus)
(make-music 'UnrelativableMusic
- 'element mus))
+ 'element mus))
(define-ly-syntax-simple (context-change type id)
(make-music 'ContextChange
- 'change-to-type type
- 'change-to-id id))
+ 'change-to-type type
+ 'change-to-id id))
(define-ly-syntax-simple (voice-separator)
(make-music 'VoiceSeparator))
(define-ly-syntax (tempo parser location text . rest)
(let* ((unit (and (pair? rest)
- (car rest)))
- (count (and unit
- (cadr rest)))
- (range-tempo? (pair? count))
- (tempo-change (make-music 'TempoChangeEvent
- 'origin location
- 'text text
- 'tempo-unit unit
- 'metronome-count count))
- (tempo-set
- (and unit
- (context-spec-music
- (make-property-set 'tempoWholesPerMinute
- (ly:moment-mul
- (ly:make-moment
- (if range-tempo?
- (round (/ (+ (car count) (cdr count))
- 2))
- count)
- 1)
- (ly:duration-length unit)))
- 'Score))))
+ (car rest)))
+ (count (and unit
+ (cadr rest)))
+ (range-tempo? (pair? count))
+ (tempo-change (make-music 'TempoChangeEvent
+ 'origin location
+ 'text text
+ 'tempo-unit unit
+ 'metronome-count count))
+ (tempo-set
+ (and unit
+ (context-spec-music
+ (make-property-set 'tempoWholesPerMinute
+ (ly:moment-mul
+ (ly:make-moment
+ (if range-tempo?
+ (round (/ (+ (car count) (cdr count))
+ 2))
+ count)
+ 1)
+ (ly:duration-length unit)))
+ 'Score))))
(if tempo-set
- (make-sequential-music (list tempo-change tempo-set))
- tempo-change)))
+ (make-sequential-music (list tempo-change tempo-set))
+ tempo-change)))
(define-ly-syntax-simple (repeat type num body alts)
(make-repeat type num body alts))
(if (memq 'script-event (ly:music-property music 'types))
(apply make-music 'MultiMeasureTextEvent
- (flatten-alist (ly:music-mutable-properties music)))
+ (flatten-alist (ly:music-mutable-properties music)))
music))
(define-ly-syntax (multi-measure-rest parser location duration articulations)
(make-music 'MultiMeasureRestMusic
- 'articulations (map script-to-mmrest-text articulations)
- 'duration duration
- 'origin location))
+ 'articulations (map script-to-mmrest-text articulations)
+ 'duration duration
+ 'origin location))
(define-ly-syntax (repetition-chord parser location duration articulations)
(make-music 'EventChord
- 'duration duration
- 'elements articulations
- 'origin location))
+ 'duration duration
+ 'elements articulations
+ 'origin location))
(define-ly-syntax-simple (context-specification type id ops create-new mus)
(let* ((type-sym (if (symbol? type) type (string->symbol type)))
- (csm (context-spec-music mus type-sym id)))
+ (csm (context-spec-music mus type-sym id)))
(set! (ly:music-property csm 'property-operations) ops)
(if create-new (set! (ly:music-property csm 'create-new) #t))
csm))
(define-ly-syntax (composed-markup-list parser location commands markups)
-;; `markups' being a list of markups, eg (markup1 markup2 markup3),
-;; and `commands' a list of commands with their scheme arguments, in reverse order,
-;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
-;; ((bold (raise 4 (italic markup1)))
-;; (bold (raise 4 (italic markup2)))
-;; (bold (raise 4 (italic markup3))))
+ ;; `markups' being a list of markups, eg (markup1 markup2 markup3),
+ ;; and `commands' a list of commands with their scheme arguments, in reverse order,
+ ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
+ ;; ((bold (raise 4 (italic markup1)))
+ ;; (bold (raise 4 (italic markup2)))
+ ;; (bold (raise 4 (italic markup3))))
(define (compose arg)
(fold
(define-ly-syntax (property-operation parser location ctx music-type symbol . args)
(let* ((props (case music-type
- ((PropertySet) (list 'value (car args)))
- ((PropertyUnset) '())
- ((OverrideProperty) (list 'grob-value (car args)
- 'grob-property-path (if (list? (cadr args))
- (cadr args)
- (cdr args))
- 'pop-first #t))
- ((RevertProperty)
- (if (list? (car args))
- (list 'grob-property-path (car args))
- (list 'grob-property-path args)))
- (else (ly:error (_ "Invalid property operation ~a") music-type))))
- (m (apply make-music music-type
- 'symbol symbol
- 'origin location
- props)))
+ ((PropertySet) (list 'value (car args)))
+ ((PropertyUnset) '())
+ ((OverrideProperty) (list 'grob-value (car args)
+ 'grob-property-path (if (list? (cadr args))
+ (cadr args)
+ (cdr args))
+ 'pop-first #t))
+ ((RevertProperty)
+ (if (list? (car args))
+ (list 'grob-property-path (car args))
+ (list 'grob-property-path args)))
+ (else (ly:error (_ "Invalid property operation ~a") music-type))))
+ (m (apply make-music music-type
+ 'symbol symbol
+ 'origin location
+ props)))
(make-music 'ContextSpeccedMusic
- 'element m
- 'context-type ctx
- 'origin location)))
+ 'element m
+ 'context-type ctx
+ 'origin location)))
;; TODO: It seems that this function rarely returns anything useful.
(define (get-first-context-id type mus)
"Find the name of a ContextSpeccedMusic with given type"
(let ((id (ly:music-property mus 'context-id)))
(if (and (eq? (ly:music-property mus 'type) 'ContextSpeccedMusic)
- (eq? (ly:music-property mus 'context-type) type)
- (string? id)
- (not (string-null? id)))
- id
- '())))
+ (eq? (ly:music-property mus 'context-type) type)
+ (string? id)
+ (not (string-null? id)))
+ id
+ '())))
(define unique-counter -1)
(define (get-next-unique-voice-name)
;; to signal to the Extender_engraver that any pending extender should
;; be completed if the lyrics end before the associated voice.
(append! (ly:music-property music 'elements)
- (list (make-music 'CompletizeExtenderEvent)))
+ (list (make-music 'CompletizeExtenderEvent)))
(make-music 'LyricCombineMusic
- 'element music
- 'associated-context sync
- 'origin loc))
+ 'element music
+ 'associated-context sync
+ 'origin loc))
(define-ly-syntax (lyric-combine parser location voice music)
(lyric-combine-music voice music location))
(define-ly-syntax (add-lyrics parser location music addlyrics-list)
(let* ((existing-voice-name (get-first-context-id 'Voice music))
- (voice-name (if (string? existing-voice-name)
- existing-voice-name
- (get-next-unique-voice-name)))
- (voice (if (string? existing-voice-name)
- (music)
- (make-music 'ContextSpeccedMusic
- 'element music
- 'context-type 'Voice
- 'context-id voice-name
- 'origin (ly:music-property music 'origin))))
- (lyricstos (map (lambda (mus)
- (let* ((loc (ly:music-property mus 'origin))
- (lyr (lyric-combine-music voice-name mus loc)))
- (make-music 'ContextSpeccedMusic
- 'create-new #t
- 'context-type 'Lyrics
- 'element lyr
- 'origin loc)))
- addlyrics-list)))
+ (voice-name (if (string? existing-voice-name)
+ existing-voice-name
+ (get-next-unique-voice-name)))
+ (voice (if (string? existing-voice-name)
+ (music)
+ (make-music 'ContextSpeccedMusic
+ 'element music
+ 'context-type 'Voice
+ 'context-id voice-name
+ 'origin (ly:music-property music 'origin))))
+ (lyricstos (map (lambda (mus)
+ (let* ((loc (ly:music-property mus 'origin))
+ (lyr (lyric-combine-music voice-name mus loc)))
+ (make-music 'ContextSpeccedMusic
+ 'create-new #t
+ 'context-type 'Lyrics
+ 'element lyr
+ 'origin loc)))
+ addlyrics-list)))
(make-simultaneous-music (cons voice lyricstos))))
((not (null? (cdr prop-spec)))
`(list ',(car prop-spec) ,(cadr prop-spec)))
(else
- `(list ',(car prop-spec)))))
+ `(list ',(car prop-spec)))))
(if (pair? args)
properties
(list)))))
((not (null? (cdr prop-spec)))
`(list ',(car prop-spec) ,(cadr prop-spec)))
(else
- `(list ',(car prop-spec)))))
+ `(list ',(car prop-spec)))))
(if (pair? args)
properties
(list)))))
(set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
(set! rest (cdr rest)))
(else
- ;; pick up one arg in `rest'
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r))))))))
+ ;; pick up one arg in `rest'
+ (receive (a r) (compile-markup-arg rest)
+ (set! args (cons a args))
+ (set! rest r))))))))
((and (pair? expr)
(pair? (car expr))
(keyword? (caar expr)))
(string? (car expr))) ;; expr === ("string" ...)
(values `(make-simple-markup ,(car expr)) (cdr expr)))
(else
- ;; expr === (symbol ...) or ((funcall ...) ...)
- (values (car expr)
- (cdr expr)))))
+ ;; expr === (symbol ...) or ((funcall ...) ...)
+ (values (car expr)
+ (cdr expr)))))
(define (compile-all-markup-args expr)
"Transform `expr' into markup arguments"
;;; convert a full markup object to an approximate pure string representation
(define-public (markup->string m . argscopes)
-(let* ((scopes (if (pair? argscopes) (car argscopes) '())))
- ;; markup commands with one markup argument, formatting ignored
- (define markups-first-argument '(list
- bold-markup box-markup caps-markup dynamic-markup finger-markup
- fontCaps-markup huge-markup italic-markup large-markup larger-markup
- medium-markup normal-size-sub-markup normal-size-super-markup
- normal-text-markup normalsize-markup number-markup roman-markup
- sans-markup simple-markup small-markup smallCaps-markup smaller-markup
- sub-markup super-markup teeny-markup text-markup tiny-markup
- typewriter-markup underline-markup upright-markup bracket-markup
- circle-markup hbracket-markup parenthesize-markup rounded-box-markup
-
- center-align-markup center-column-markup column-markup dir-column-markup
- fill-line-markup justify-markup justify-string-markup left-align-markup
- left-column-markup line-markup right-align-markup right-column-markup
- vcenter-markup wordwrap-markup wordwrap-string-markup ))
-
- ;; markup commands with markup as second argument, first argument
- ;; specifies some formatting and is ignored
- (define markups-second-argument '(list
- abs-fontsize-markup fontsize-markup magnify-markup lower-markup
- pad-around-markup pad-markup-markup pad-x-markup raise-markup
- halign-markup hcenter-in-markup rotate-markup translate-markup
- translate-scaled-markup with-url-markup scale-markup ))
-
- ;; helper functions to handle string cons like string lists
- (define (markup-cons->string-cons c scopes)
- (if (not (pair? c)) (markup->string c scopes)
- (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes))))
- (define (string-cons-join c)
- (if (not (pair? c)) c
- (string-join (list (car c) (string-cons-join (cdr c))) "")))
-
- (cond
- ((string? m) m)
- ((null? m) "")
- ((not (pair? m)) "")
-
- ;; handle \concat (string-join without spaces)
- ((and (pair? m) (equal? (car m) concat-markup))
- (string-cons-join (markup-cons->string-cons (cadr m) scopes)) )
-
- ;; markup functions with the markup as first arg
- ((member (car m) (primitive-eval markups-first-argument))
- (markup->string (cadr m) scopes))
-
- ;; markup functions with markup as second arg
- ((member (car m) (primitive-eval markups-second-argument))
- (markup->string (cddr m) scopes))
-
- ;; fromproperty-markup reads property values from the header block:
- ((equal? (car m) fromproperty-markup)
- (let* ((varname (symbol->string (cadr m)))
- ;; cut off the header: prefix from the variable name:
- (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname))
- (var (string->symbol newvarname))
- (mod (make-module 1)))
- ;; Prevent loops by temporarily clearing the variable we have just looked up
- (module-define! mod var "")
- (markup->string (ly:modules-lookup scopes var) (cons mod scopes))))
-
- ;; ignore all other markup functions
- ((markup-function? (car m)) "")
-
- ;; handle markup lists
- ((list? m)
- (string-join (map (lambda (mm) (markup->string mm scopes)) m) " "))
-
- (else "ERROR, unable to extract string from markup"))))
+ (let* ((scopes (if (pair? argscopes) (car argscopes) '())))
+ ;; markup commands with one markup argument, formatting ignored
+ (define markups-first-argument '(list
+ bold-markup box-markup caps-markup dynamic-markup finger-markup
+ fontCaps-markup huge-markup italic-markup large-markup larger-markup
+ medium-markup normal-size-sub-markup normal-size-super-markup
+ normal-text-markup normalsize-markup number-markup roman-markup
+ sans-markup simple-markup small-markup smallCaps-markup smaller-markup
+ sub-markup super-markup teeny-markup text-markup tiny-markup
+ typewriter-markup underline-markup upright-markup bracket-markup
+ circle-markup hbracket-markup parenthesize-markup rounded-box-markup
+
+ center-align-markup center-column-markup column-markup dir-column-markup
+ fill-line-markup justify-markup justify-string-markup left-align-markup
+ left-column-markup line-markup right-align-markup right-column-markup
+ vcenter-markup wordwrap-markup wordwrap-string-markup ))
+
+ ;; markup commands with markup as second argument, first argument
+ ;; specifies some formatting and is ignored
+ (define markups-second-argument '(list
+ abs-fontsize-markup fontsize-markup magnify-markup lower-markup
+ pad-around-markup pad-markup-markup pad-x-markup raise-markup
+ halign-markup hcenter-in-markup rotate-markup translate-markup
+ translate-scaled-markup with-url-markup scale-markup ))
+
+ ;; helper functions to handle string cons like string lists
+ (define (markup-cons->string-cons c scopes)
+ (if (not (pair? c)) (markup->string c scopes)
+ (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes))))
+ (define (string-cons-join c)
+ (if (not (pair? c)) c
+ (string-join (list (car c) (string-cons-join (cdr c))) "")))
+
+ (cond
+ ((string? m) m)
+ ((null? m) "")
+ ((not (pair? m)) "")
+
+ ;; handle \concat (string-join without spaces)
+ ((and (pair? m) (equal? (car m) concat-markup))
+ (string-cons-join (markup-cons->string-cons (cadr m) scopes)) )
+
+ ;; markup functions with the markup as first arg
+ ((member (car m) (primitive-eval markups-first-argument))
+ (markup->string (cadr m) scopes))
+
+ ;; markup functions with markup as second arg
+ ((member (car m) (primitive-eval markups-second-argument))
+ (markup->string (cddr m) scopes))
+
+ ;; fromproperty-markup reads property values from the header block:
+ ((equal? (car m) fromproperty-markup)
+ (let* ((varname (symbol->string (cadr m)))
+ ;; cut off the header: prefix from the variable name:
+ (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname))
+ (var (string->symbol newvarname))
+ (mod (make-module 1)))
+ ;; Prevent loops by temporarily clearing the variable we have just looked up
+ (module-define! mod var "")
+ (markup->string (ly:modules-lookup scopes var) (cons mod scopes))))
+
+ ;; ignore all other markup functions
+ ((markup-function? (car m)) "")
+
+ ;; handle markup lists
+ ((list? m)
+ (string-join (map (lambda (mm) (markup->string mm scopes)) m) " "))
+
+ (else "ERROR, unable to extract string from markup"))))
(define-module (scm memory-trace))
(use-modules (lily)
- (ice-9 format))
+ (ice-9 format))
(define-public (mtrace:start-trace freq)
(set! usecond-interval (inexact->exact (/ 1000000 freq)))
(define usecond-interval 100000)
(define (arg-procedure args)
(if (and (pair? args)
- (pair? (cdr args))
- (pair? (cadr args)))
+ (pair? (cdr args))
+ (pair? (cadr args)))
(caadr args) #f))
(define last-count 0)
(define (record-stack key continuation . args)
(if (eq? (current-thread) trace-thread)
#t ;; do nothing.
(let*
- ((cells (assoc-get 'total-cells-allocated (gc-stats)))
- (proc (arg-procedure args))
- (time (tms:utime (times)))
- (stack (extract-trace continuation)))
-
- (set! busy-tracing #t)
- (trap-disable 'traps)
- (trap-disable 'enter-frame)
-
- (set! trace-count (1+ trace-count))
- (ly:progress "<~a: ~a/~a>\n"
- trace-count
- (- time start-time)
- (- cells last-count))
-
- (set! last-count cells)
- (set! trace-points
- (cons (list
- (cons 'cells cells)
- (cons 'proc proc)
- (cons 'stack stack)
- (cons 'time time)
- )
-
- trace-points))
-
- (set! busy-tracing #f))))
+ ((cells (assoc-get 'total-cells-allocated (gc-stats)))
+ (proc (arg-procedure args))
+ (time (tms:utime (times)))
+ (stack (extract-trace continuation)))
+
+ (set! busy-tracing #t)
+ (trap-disable 'traps)
+ (trap-disable 'enter-frame)
+
+ (set! trace-count (1+ trace-count))
+ (ly:progress "<~a: ~a/~a>\n"
+ trace-count
+ (- time start-time)
+ (- cells last-count))
+
+ (set! last-count cells)
+ (set! trace-points
+ (cons (list
+ (cons 'cells cells)
+ (cons 'proc proc)
+ (cons 'stack stack)
+ (cons 'time time)
+ )
+
+ trace-points))
+
+ (set! busy-tracing #f))))
(define (start-install-tracepoint)
(set! trace-thread (current-thread))
(set! trace-count 0)
(set! start-memory (assoc-get 'total-cells-allocated (gc-stats)))
(set! start-time (tms:utime (times)))
-
+
(install-tracepoint))
(define (install-tracepoint)
(if busy-tracing
(display "last trace not finished yet\n" (current-error-port))
(begin
- (trap-set! enter-frame-handler record-stack)
- (trap-enable 'enter-frame)
- (trap-enable 'traps)))
-
+ (trap-set! enter-frame-handler record-stack)
+ (trap-enable 'enter-frame)
+ (trap-enable 'traps)))
+
(usleep usecond-interval)
(if continue-tracing
(install-tracepoint)))
)
(ly:progress "Memory statistics to ~a and ~a..."
- stacks-name graph-name)
+ stacks-name graph-name)
(format graph-out "# memory trace with ~a points\n" (length trace-points))
(for-each
(lambda (r)
(let*
- ((mem (- (assoc-get 'cells r) start-memory))
- (proc (assoc-get 'proc r))
- (stack (assoc-get 'stack r))
- (time (- (assoc-get 'time r) start-time)))
-
- (format graph-out "~a ~a\n" time mem)
- (if stack
- (begin
- (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a\n" i
- time
- (- mem last-mem) proc)
- (do
- ((j 0 (1+ j))
- (stack (assoc-get 'stack r) stack))
- ((>= j (vector-length stack)))
-
- (format stacks-out "\t~a\n"
- (vector-ref stack j)))))
-
- (set! i (1+ i))
- (set! last-mem mem)
- ))
+ ((mem (- (assoc-get 'cells r) start-memory))
+ (proc (assoc-get 'proc r))
+ (stack (assoc-get 'stack r))
+ (time (- (assoc-get 'time r) start-time)))
+
+ (format graph-out "~a ~a\n" time mem)
+ (if stack
+ (begin
+ (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a\n" i
+ time
+ (- mem last-mem) proc)
+ (do
+ ((j 0 (1+ j))
+ (stack (assoc-get 'stack r) stack))
+ ((>= j (vector-length stack)))
+
+ (format stacks-out "\t~a\n"
+ (vector-ref stack j)))))
+
+ (set! i (1+ i))
+ (set! last-mem mem)
+ ))
(reverse trace-points))))
(trace (make-vector depth #f)))
(do
- ((i 0 (1+ i)))
- ((>= i depth))
+ ((i 0 (1+ i)))
+ ((>= i depth))
(vector-set!
trace i
(let*
- ((source (frame-source (stack-ref stack i))))
+ ((source (frame-source (stack-ref stack i))))
- (and source
- (cons (source-property source 'filename)
- (source-property source 'line))))))
+ (and source
+ (cons (source-property source 'filename)
+ (source-property source 'line))))))
trace))
-
-
-
-
(set! absolute-volume-alist
(append
'(
- ("sf" . 1.00)
- ("fffff" . 0.95)
- ("ffff" . 0.92)
- ("fff" . 0.85)
- ("ff" . 0.80)
- ("f" . 0.75)
- ("mf" . 0.68)
- ("mp" . 0.61)
- ("p" . 0.55)
- ("pp" . 0.49)
- ("ppp" . 0.42)
- ("pppp" . 0.34)
- ("ppppp" . 0.25)
- )
+ ("sf" . 1.00)
+ ("fffff" . 0.95)
+ ("ffff" . 0.92)
+ ("fff" . 0.85)
+ ("ff" . 0.80)
+ ("f" . 0.75)
+ ("mf" . 0.68)
+ ("mp" . 0.61)
+ ("p" . 0.55)
+ ("pp" . 0.49)
+ ("ppp" . 0.42)
+ ("pppp" . 0.34)
+ ("ppppp" . 0.25)
+ )
absolute-volume-alist))
(define-public (default-dynamic-absolute-volume s)
(set! instrument-equalizer-alist
(append
'(
- ("flute" . (0 . 0.7))
- ("oboe" . (0 . 0.7))
- ("clarinet" . (0 . 0.7))
- ("bassoon" . (0 . 0.6))
- ("french horn" . (0.1 . 0.7))
- ("trumpet" . (0.1 . 0.8))
- ("timpani" . (0.2 . 0.9))
- ("violin" . (0.2 . 1.0))
- ("viola" . (0.1 . 0.7))
- ("cello" . (0.2 . 0.8))
- ("contrabass" . (0.2 . 0.8))
- )
+ ("flute" . (0 . 0.7))
+ ("oboe" . (0 . 0.7))
+ ("clarinet" . (0 . 0.7))
+ ("bassoon" . (0 . 0.6))
+ ("french horn" . (0.1 . 0.7))
+ ("trumpet" . (0.1 . 0.8))
+ ("timpani" . (0.2 . 0.9))
+ ("violin" . (0.2 . 1.0))
+ ("viola" . (0.1 . 0.7))
+ ("cello" . (0.2 . 0.8))
+ ("contrabass" . (0.2 . 0.8))
+ )
instrument-equalizer-alist))
(define-public (default-instrument-equalizer s)
(set! instrument-names-alist
(append
`(
- ("acoustic grand" . ,(- 1 1))
- ("bright acoustic" . ,(- 2 1))
- ("electric grand" . ,(- 3 1))
- ("honky-tonk" . ,(- 4 1))
- ("electric piano 1" . ,(- 5 1))
- ("electric piano 2" . ,(- 6 1))
- ("harpsichord" . ,(- 7 1))
- ("clav" . ,(- 8 1))
-
- ;; (9-16 chrom percussion)
- ("celesta" . ,(- 9 1))
- ("glockenspiel" . ,(- 10 1))
- ("music box" . ,(- 11 1))
- ("vibraphone" . ,(- 12 1))
- ("marimba" . ,(- 13 1))
- ("xylophone" . ,(- 14 1))
- ("tubular bells" . ,(- 15 1))
- ("dulcimer" . ,(- 16 1))
-
- ;; (17-24 organ)
- ("drawbar organ" . ,(- 17 1))
- ("percussive organ" . ,(- 18 1))
- ("rock organ" . ,(- 19 1))
- ("church organ" . ,(- 20 1))
- ("reed organ" . ,(- 21 1))
- ("accordion" . ,(- 22 1))
- ("harmonica" . ,(- 23 1))
- ("concertina" . ,(- 24 1))
-
- ;; (25-32 guitar)
- ("acoustic guitar (nylon)" . ,(- 25 1))
- ("acoustic guitar (steel)" . ,(- 26 1))
- ("electric guitar (jazz)" . ,(- 27 1))
- ("electric guitar (clean)" . ,(- 28 1))
- ("electric guitar (muted)" . ,(- 29 1))
- ("overdriven guitar" . ,(- 30 1))
- ("distorted guitar" . ,(- 31 1))
- ("guitar harmonics" . ,(- 32 1))
-
- ;; (33-40 bass)
- ("acoustic bass" . ,(- 33 1))
- ("electric bass (finger)" . ,(- 34 1))
- ("electric bass (pick)" . ,(- 35 1))
- ("fretless bass" . ,(- 36 1))
- ("slap bass 1" . ,(- 37 1))
- ("slap bass 2" . ,(- 38 1))
- ("synth bass 1" . ,(- 39 1))
- ("synth bass 2" . ,(- 40 1))
-
- ;; (41-48 strings)
- ("violin" . ,(- 41 1))
- ("viola" . ,(- 42 1))
- ("cello" . ,(- 43 1))
- ("contrabass" . ,(- 44 1))
- ("tremolo strings" . ,(- 45 1))
- ("pizzicato strings" . ,(- 46 1))
- ("orchestral harp" . ,(- 47 1))
- ("timpani" . ,(- 48 1))
-
- ;; (49-56 ensemble)
- ("string ensemble 1" . ,(- 49 1))
- ("string ensemble 2" . ,(- 50 1))
- ("synthstrings 1" . ,(- 51 1))
- ("synthstrings 2" . ,(- 52 1))
- ("choir aahs" . ,(- 53 1))
- ("voice oohs" . ,(- 54 1))
- ("synth voice" . ,(- 55 1))
- ("orchestra hit" . ,(- 56 1))
-
- ;; (57-64 brass)
- ("trumpet" . ,(- 57 1))
- ("trombone" . ,(- 58 1))
- ("tuba" . ,(- 59 1))
- ("muted trumpet" . ,(- 60 1))
- ("french horn" . ,(- 61 1))
- ("brass section" . ,(- 62 1))
- ("synthbrass 1" . ,(- 63 1))
- ("synthbrass 2" . ,(- 64 1))
-
- ;; (65-72 reed)
- ("soprano sax" . ,(- 65 1))
- ("alto sax" . ,(- 66 1))
- ("tenor sax" . ,(- 67 1))
- ("baritone sax" . ,(- 68 1))
- ("oboe" . ,(- 69 1))
- ("english horn" . ,(- 70 1))
- ("bassoon" . ,(- 71 1))
- ("clarinet" . ,(- 72 1))
-
- ;; (73-80 pipe)
- ("piccolo" . ,(- 73 1))
- ("flute" . ,(- 74 1))
- ("recorder" . ,(- 75 1))
- ("pan flute" . ,(- 76 1))
- ("blown bottle" . ,(- 77 1))
- ("shakuhachi" . ,(- 78 1))
- ("whistle" . ,(- 79 1))
- ("ocarina" . ,(- 80 1))
-
- ;; (81-88 synth lead)
- ("lead 1 (square)" . ,(- 81 1))
- ("lead 2 (sawtooth)" . ,(- 82 1))
- ("lead 3 (calliope)" . ,(- 83 1))
- ("lead 4 (chiff)" . ,(- 84 1))
- ("lead 5 (charang)" . ,(- 85 1))
- ("lead 6 (voice)" . ,(- 86 1))
- ("lead 7 (fifths)" . ,(- 87 1))
- ("lead 8 (bass+lead)" . ,(- 88 1))
-
- ;; (89-96 synth pad)
- ("pad 1 (new age)" . ,(- 89 1))
- ("pad 2 (warm)" . ,(- 90 1))
- ("pad 3 (polysynth)" . ,(- 91 1))
- ("pad 4 (choir)" . ,(- 92 1))
- ("pad 5 (bowed)" . ,(- 93 1))
- ("pad 6 (metallic)" . ,(- 94 1))
- ("pad 7 (halo)" . ,(- 95 1))
- ("pad 8 (sweep)" . ,(- 96 1))
-
- ;; (97-104 synth effects)
- ("fx 1 (rain)" . ,(- 97 1))
- ("fx 2 (soundtrack)" . ,(- 98 1))
- ("fx 3 (crystal)" . ,(- 99 1))
- ("fx 4 (atmosphere)" . ,(- 100 1))
- ("fx 5 (brightness)" . ,(- 101 1))
- ("fx 6 (goblins)" . ,(- 102 1))
- ("fx 7 (echoes)" . ,(- 103 1))
- ("fx 8 (sci-fi)" . ,(- 104 1))
-
- ;; (105-112 ethnic)
- ("sitar" . ,(- 105 1))
- ("banjo" . ,(- 106 1))
- ("shamisen" . ,(- 107 1))
- ("koto" . ,(- 108 1))
- ("kalimba" . ,(- 109 1))
- ("bagpipe" . ,(- 110 1))
- ("fiddle" . ,(- 111 1))
- ("shanai" . ,(- 112 1))
-
- ;; (113-120 percussive)
- ("tinkle bell" . ,(- 113 1))
- ("agogo" . ,(- 114 1))
- ("steel drums" . ,(- 115 1))
- ("woodblock" . ,(- 116 1))
- ("taiko drum" . ,(- 117 1))
- ("melodic tom" . ,(- 118 1))
- ("synth drum" . ,(- 119 1))
- ("reverse cymbal" . ,(- 120 1))
-
- ;; (121-128 sound effects)
- ("guitar fret noise" . ,(- 121 1))
- ("breath noise" . ,(- 122 1))
- ("seashore" . ,(- 123 1))
- ("bird tweet" . ,(- 124 1))
- ("telephone ring" . ,(- 125 1))
- ("helicopter" . ,(- 126 1))
- ("applause" . ,(- 127 1))
- ("gunshot" . ,(- 128 1))
-
- ;; (channel 10 drum-kits - subtract 32768 to get program no.)
- ("standard kit" . ,(+ 32768 0))
- ("standard drums" . ,(+ 32768 0))
- ("drums" . ,(+ 32768 0))
- ("room kit" . ,(+ 32768 8))
- ("room drums" . ,(+ 32768 8))
- ("power kit" . ,(+ 32768 16))
- ("power drums" . ,(+ 32768 16))
- ("rock drums" . ,(+ 32768 16))
- ("electronic kit" . ,(+ 32768 24))
- ("electronic drums" . ,(+ 32768 24))
- ("tr-808 kit" . ,(+ 32768 25))
- ("tr-808 drums" . ,(+ 32768 25))
- ("jazz kit" . ,(+ 32768 32))
- ("jazz drums" . ,(+ 32768 32))
- ("brush kit" . ,(+ 32768 40))
- ("brush drums" . ,(+ 32768 40))
- ("orchestra kit" . ,(+ 32768 48))
- ("orchestra drums" . ,(+ 32768 48))
- ("classical drums" . ,(+ 32768 48))
- ("sfx kit" . ,(+ 32768 56))
- ("sfx drums" . ,(+ 32768 56))
- ("mt-32 kit" . ,(+ 32768 127))
- ("mt-32 drums" . ,(+ 32768 127))
- ("cm-64 kit" . ,(+ 32768 127))
- ("cm-64 drums" . ,(+ 32768 127))
- )
+ ("acoustic grand" . ,(- 1 1))
+ ("bright acoustic" . ,(- 2 1))
+ ("electric grand" . ,(- 3 1))
+ ("honky-tonk" . ,(- 4 1))
+ ("electric piano 1" . ,(- 5 1))
+ ("electric piano 2" . ,(- 6 1))
+ ("harpsichord" . ,(- 7 1))
+ ("clav" . ,(- 8 1))
+
+ ;; (9-16 chrom percussion)
+ ("celesta" . ,(- 9 1))
+ ("glockenspiel" . ,(- 10 1))
+ ("music box" . ,(- 11 1))
+ ("vibraphone" . ,(- 12 1))
+ ("marimba" . ,(- 13 1))
+ ("xylophone" . ,(- 14 1))
+ ("tubular bells" . ,(- 15 1))
+ ("dulcimer" . ,(- 16 1))
+
+ ;; (17-24 organ)
+ ("drawbar organ" . ,(- 17 1))
+ ("percussive organ" . ,(- 18 1))
+ ("rock organ" . ,(- 19 1))
+ ("church organ" . ,(- 20 1))
+ ("reed organ" . ,(- 21 1))
+ ("accordion" . ,(- 22 1))
+ ("harmonica" . ,(- 23 1))
+ ("concertina" . ,(- 24 1))
+
+ ;; (25-32 guitar)
+ ("acoustic guitar (nylon)" . ,(- 25 1))
+ ("acoustic guitar (steel)" . ,(- 26 1))
+ ("electric guitar (jazz)" . ,(- 27 1))
+ ("electric guitar (clean)" . ,(- 28 1))
+ ("electric guitar (muted)" . ,(- 29 1))
+ ("overdriven guitar" . ,(- 30 1))
+ ("distorted guitar" . ,(- 31 1))
+ ("guitar harmonics" . ,(- 32 1))
+
+ ;; (33-40 bass)
+ ("acoustic bass" . ,(- 33 1))
+ ("electric bass (finger)" . ,(- 34 1))
+ ("electric bass (pick)" . ,(- 35 1))
+ ("fretless bass" . ,(- 36 1))
+ ("slap bass 1" . ,(- 37 1))
+ ("slap bass 2" . ,(- 38 1))
+ ("synth bass 1" . ,(- 39 1))
+ ("synth bass 2" . ,(- 40 1))
+
+ ;; (41-48 strings)
+ ("violin" . ,(- 41 1))
+ ("viola" . ,(- 42 1))
+ ("cello" . ,(- 43 1))
+ ("contrabass" . ,(- 44 1))
+ ("tremolo strings" . ,(- 45 1))
+ ("pizzicato strings" . ,(- 46 1))
+ ("orchestral harp" . ,(- 47 1))
+ ("timpani" . ,(- 48 1))
+
+ ;; (49-56 ensemble)
+ ("string ensemble 1" . ,(- 49 1))
+ ("string ensemble 2" . ,(- 50 1))
+ ("synthstrings 1" . ,(- 51 1))
+ ("synthstrings 2" . ,(- 52 1))
+ ("choir aahs" . ,(- 53 1))
+ ("voice oohs" . ,(- 54 1))
+ ("synth voice" . ,(- 55 1))
+ ("orchestra hit" . ,(- 56 1))
+
+ ;; (57-64 brass)
+ ("trumpet" . ,(- 57 1))
+ ("trombone" . ,(- 58 1))
+ ("tuba" . ,(- 59 1))
+ ("muted trumpet" . ,(- 60 1))
+ ("french horn" . ,(- 61 1))
+ ("brass section" . ,(- 62 1))
+ ("synthbrass 1" . ,(- 63 1))
+ ("synthbrass 2" . ,(- 64 1))
+
+ ;; (65-72 reed)
+ ("soprano sax" . ,(- 65 1))
+ ("alto sax" . ,(- 66 1))
+ ("tenor sax" . ,(- 67 1))
+ ("baritone sax" . ,(- 68 1))
+ ("oboe" . ,(- 69 1))
+ ("english horn" . ,(- 70 1))
+ ("bassoon" . ,(- 71 1))
+ ("clarinet" . ,(- 72 1))
+
+ ;; (73-80 pipe)
+ ("piccolo" . ,(- 73 1))
+ ("flute" . ,(- 74 1))
+ ("recorder" . ,(- 75 1))
+ ("pan flute" . ,(- 76 1))
+ ("blown bottle" . ,(- 77 1))
+ ("shakuhachi" . ,(- 78 1))
+ ("whistle" . ,(- 79 1))
+ ("ocarina" . ,(- 80 1))
+
+ ;; (81-88 synth lead)
+ ("lead 1 (square)" . ,(- 81 1))
+ ("lead 2 (sawtooth)" . ,(- 82 1))
+ ("lead 3 (calliope)" . ,(- 83 1))
+ ("lead 4 (chiff)" . ,(- 84 1))
+ ("lead 5 (charang)" . ,(- 85 1))
+ ("lead 6 (voice)" . ,(- 86 1))
+ ("lead 7 (fifths)" . ,(- 87 1))
+ ("lead 8 (bass+lead)" . ,(- 88 1))
+
+ ;; (89-96 synth pad)
+ ("pad 1 (new age)" . ,(- 89 1))
+ ("pad 2 (warm)" . ,(- 90 1))
+ ("pad 3 (polysynth)" . ,(- 91 1))
+ ("pad 4 (choir)" . ,(- 92 1))
+ ("pad 5 (bowed)" . ,(- 93 1))
+ ("pad 6 (metallic)" . ,(- 94 1))
+ ("pad 7 (halo)" . ,(- 95 1))
+ ("pad 8 (sweep)" . ,(- 96 1))
+
+ ;; (97-104 synth effects)
+ ("fx 1 (rain)" . ,(- 97 1))
+ ("fx 2 (soundtrack)" . ,(- 98 1))
+ ("fx 3 (crystal)" . ,(- 99 1))
+ ("fx 4 (atmosphere)" . ,(- 100 1))
+ ("fx 5 (brightness)" . ,(- 101 1))
+ ("fx 6 (goblins)" . ,(- 102 1))
+ ("fx 7 (echoes)" . ,(- 103 1))
+ ("fx 8 (sci-fi)" . ,(- 104 1))
+
+ ;; (105-112 ethnic)
+ ("sitar" . ,(- 105 1))
+ ("banjo" . ,(- 106 1))
+ ("shamisen" . ,(- 107 1))
+ ("koto" . ,(- 108 1))
+ ("kalimba" . ,(- 109 1))
+ ("bagpipe" . ,(- 110 1))
+ ("fiddle" . ,(- 111 1))
+ ("shanai" . ,(- 112 1))
+
+ ;; (113-120 percussive)
+ ("tinkle bell" . ,(- 113 1))
+ ("agogo" . ,(- 114 1))
+ ("steel drums" . ,(- 115 1))
+ ("woodblock" . ,(- 116 1))
+ ("taiko drum" . ,(- 117 1))
+ ("melodic tom" . ,(- 118 1))
+ ("synth drum" . ,(- 119 1))
+ ("reverse cymbal" . ,(- 120 1))
+
+ ;; (121-128 sound effects)
+ ("guitar fret noise" . ,(- 121 1))
+ ("breath noise" . ,(- 122 1))
+ ("seashore" . ,(- 123 1))
+ ("bird tweet" . ,(- 124 1))
+ ("telephone ring" . ,(- 125 1))
+ ("helicopter" . ,(- 126 1))
+ ("applause" . ,(- 127 1))
+ ("gunshot" . ,(- 128 1))
+
+ ;; (channel 10 drum-kits - subtract 32768 to get program no.)
+ ("standard kit" . ,(+ 32768 0))
+ ("standard drums" . ,(+ 32768 0))
+ ("drums" . ,(+ 32768 0))
+ ("room kit" . ,(+ 32768 8))
+ ("room drums" . ,(+ 32768 8))
+ ("power kit" . ,(+ 32768 16))
+ ("power drums" . ,(+ 32768 16))
+ ("rock drums" . ,(+ 32768 16))
+ ("electronic kit" . ,(+ 32768 24))
+ ("electronic drums" . ,(+ 32768 24))
+ ("tr-808 kit" . ,(+ 32768 25))
+ ("tr-808 drums" . ,(+ 32768 25))
+ ("jazz kit" . ,(+ 32768 32))
+ ("jazz drums" . ,(+ 32768 32))
+ ("brush kit" . ,(+ 32768 40))
+ ("brush drums" . ,(+ 32768 40))
+ ("orchestra kit" . ,(+ 32768 48))
+ ("orchestra drums" . ,(+ 32768 48))
+ ("classical drums" . ,(+ 32768 48))
+ ("sfx kit" . ,(+ 32768 56))
+ ("sfx drums" . ,(+ 32768 56))
+ ("mt-32 kit" . ,(+ 32768 127))
+ ("mt-32 drums" . ,(+ 32768 127))
+ ("cm-64 kit" . ,(+ 32768 127))
+ ("cm-64 drums" . ,(+ 32768 127))
+ )
instrument-names-alist))
(define-public (percussion? instrument)
(entry (assoc-get inst instrument-names-alist)))
(if entry
(modulo entry 32768)
- #f)))
+ #f)))
;; 90 == 90/127 == 0.71 is supposed to be the default value
;; urg: we should set this at start of track
(define-public (write-performances-midis performances basename . rest)
(let ((midi-ext (ly:get-option 'midi-extension)))
(let
- loop
+ loop
((perfs performances)
(count (if (null? rest) 0 (car rest))))
(if (pair? perfs)
- (begin
- (ly:performance-write
- (car perfs)
- (if (> count 0)
- (format #f "~a-~a.~a" basename count midi-ext)
- (format #f "~a.~a" basename midi-ext)))
- (loop (cdr perfs) (1+ count)))))))
+ (begin
+ (ly:performance-write
+ (car perfs)
+ (if (> count 0)
+ (format #f "~a-~a.~a" basename count midi-ext)
+ (format #f "~a.~a" basename midi-ext)))
+ (loop (cdr perfs) (1+ count)))))))
(else
(list-ref scale
- (modulo
- (+ (index pitch scale)
- (- (index to-pitch scale)
- (index from-pitch scale)))
- (length scale)))))))
+ (modulo
+ (+ (index pitch scale)
+ (- (index to-pitch scale)
+ (index from-pitch scale)))
+ (length scale)))))))
(define (inverter-factory scale)
"Returns an inverter for the specified @var{scale}.
(else
(list-ref scale
- (modulo
- (+ (index to-pitch scale)
- (- (index around-pitch scale)
- (index pitch scale)))
- (length scale)))))))
+ (modulo
+ (+ (index to-pitch scale)
+ (- (index around-pitch scale)
+ (index pitch scale)))
+ (length scale)))))))
(define (replicate-modify lis n mod-proc)
"Apply @code{(mod-proc lis n)} to each element of a list and
LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)}
"
(let ((elements (ly:music-property music 'elements))
- (element (ly:music-property music 'element))
- (pitch (ly:music-property music 'pitch)))
+ (element (ly:music-property music 'element))
+ (pitch (ly:music-property music 'pitch)))
(cond
((ly:pitch? pitch)
"
(let ((elements (ly:music-property music 'elements))
- (element (ly:music-property music 'element))
- (pitch (ly:music-property music 'pitch)))
+ (element (ly:music-property music 'element))
+ (pitch (ly:music-property music 'pitch)))
(cond
((ly:pitch? pitch)
(lambda (lis n)
(map
(lambda (i)
- (ly:make-pitch
- (+ (- n 6) (ly:pitch-octave i))
- (ly:pitch-notename i)
- (ly:pitch-alteration i)))
+ (ly:make-pitch
+ (+ (- n 6) (ly:pitch-octave i))
+ (ly:pitch-notename i)
+ (ly:pitch-alteration i)))
lis)))
(let ((scale (make-scale music)))
and transposes from @var{around} to @var{to}."
(let ((p (ly:music-property music 'pitch)))
(if (ly:pitch? p)
- (ly:music-set-property!
- music 'pitch
- (ly:pitch-transpose to (ly:pitch-diff around p))))
+ (ly:music-set-property!
+ music 'pitch
+ (ly:pitch-transpose to (ly:pitch-diff around p))))
music))
(define-public (music-invert around to music)
"Applies pitch-invert to all pitches in @var{music}."
- (music-map (lambda (x) (pitch-invert around to x)) music))
+ (music-map (lambda (x) (pitch-invert around to x)) music))
;;; ==> set the 'elements property and return it
(define-public ly:music-property
(make-procedure-with-setter ly:music-property
- ly:music-set-property!))
+ ly:music-set-property!))
(define-safe-public (music-is-of-type? mus type)
"Does @code{mus} belong to the music class @code{type}?"
;; TODO move this
(define-public ly:grob-property
(make-procedure-with-setter ly:grob-property
- ly:grob-set-property!))
+ ly:grob-set-property!))
(define-public ly:grob-object
(make-procedure-with-setter ly:grob-object
- ly:grob-set-object!))
+ ly:grob-set-object!))
(define-public ly:grob-parent
(make-procedure-with-setter ly:grob-parent
- ly:grob-set-parent!))
+ ly:grob-set-parent!))
(define-public ly:prob-property
(make-procedure-with-setter ly:prob-property
- ly:prob-set-property!))
+ ly:prob-set-property!))
(define-public ly:context-property
(make-procedure-with-setter ly:context-property
- ly:context-set-property!))
+ ly:context-set-property!))
(define-public (music-map function music)
"Apply @var{function} to @var{music} and all of the music it contains.
First it recurses over the children, then the function is applied to
@var{music}."
(let ((es (ly:music-property music 'elements))
- (e (ly:music-property music 'element)))
+ (e (ly:music-property music 'element)))
(if (pair? es)
- (set! (ly:music-property music 'elements)
- (map (lambda (y) (music-map function y)) es)))
+ (set! (ly:music-property music 'elements)
+ (map (lambda (y) (music-map function y)) es)))
(if (ly:music? e)
- (set! (ly:music-property music 'element)
- (music-map function e)))
+ (set! (ly:music-property music 'element)
+ (music-map function e)))
(function music)))
(define-public (music-filter pred? music)
(define (inner-music-filter pred? music)
"Recursive function."
(let* ((es (ly:music-property music 'elements))
- (e (ly:music-property music 'element))
- (as (ly:music-property music 'articulations))
- (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as)))
- (filtered-e (if (ly:music? e)
- (inner-music-filter pred? e)
- e))
- (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es))))
+ (e (ly:music-property music 'element))
+ (as (ly:music-property music 'articulations))
+ (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as)))
+ (filtered-e (if (ly:music? e)
+ (inner-music-filter pred? e)
+ e))
+ (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es))))
(if (not (null? e))
- (set! (ly:music-property music 'element) filtered-e))
+ (set! (ly:music-property music 'element) filtered-e))
(if (not (null? es))
- (set! (ly:music-property music 'elements) filtered-es))
+ (set! (ly:music-property music 'elements) filtered-es))
(if (not (null? as))
- (set! (ly:music-property music 'articulations) filtered-as))
+ (set! (ly:music-property music 'articulations) filtered-as))
;; if filtering emptied the expression, we remove it completely.
(if (or (not (pred? music))
- (and (eq? filtered-es '()) (not (ly:music? e))
- (or (not (eq? es '()))
- (ly:music? e))))
- (set! music '()))
+ (and (eq? filtered-es '()) (not (ly:music? e))
+ (or (not (eq? es '()))
+ (ly:music? e))))
+ (set! music '()))
music))
(set! music (inner-music-filter pred? music))
(if (ly:music? music)
music
- (make-music 'Music))) ;must return music.
+ (make-music 'Music))) ;must return music.
(define*-public (display-music music #:optional (port (current-output-port)))
"Display music, not done with @code{music-map} for clarity of
(display music port)
(display ": { " port)
(let ((es (ly:music-property music 'elements))
- (e (ly:music-property music 'element)))
+ (e (ly:music-property music 'element)))
(display (ly:music-mutable-properties music) port)
(if (pair? es)
- (begin (display "\nElements: {\n" port)
- (for-each (lambda (m) (display-music m port)) es)
- (display "}\n" port)))
+ (begin (display "\nElements: {\n" port)
+ (for-each (lambda (m) (display-music m port)) es)
+ (display "}\n" port)))
(if (ly:music? e)
- (begin
- (display "\nChild:" port)
- (display-music e port))))
+ (begin
+ (display "\nChild:" port)
+ (display-music e port))))
(display " }\n" port)
music)
"Return a keyword, eg. `#:bold', from the `proc' function, eg. #<procedure bold-markup (layout props arg)>"
(let ((cmd-markup (symbol->string (procedure-name proc))))
(symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-markup)
- (string-length "-markup")))))))
+ (string-length "-markup")))))))
(define (transform-arg arg)
(cond ((and (pair? arg) (markup? (car arg))) ;; a markup list
- (apply append (map inner-markup->make-markup arg)))
- ((and (not (string? arg)) (markup? arg)) ;; a markup
- (inner-markup->make-markup arg))
- (else ;; scheme arg
- (music->make-music arg))))
+ (apply append (map inner-markup->make-markup arg)))
+ ((and (not (string? arg)) (markup? arg)) ;; a markup
+ (inner-markup->make-markup arg))
+ (else ;; scheme arg
+ (music->make-music arg))))
(define (inner-markup->make-markup mrkup)
(if (string? mrkup)
- `(#:simple ,mrkup)
- (let ((cmd (proc->command-keyword (car mrkup)))
- (args (map transform-arg (cdr mrkup))))
- `(,cmd ,@args))))
+ `(#:simple ,mrkup)
+ (let ((cmd (proc->command-keyword (car mrkup)))
+ (args (map transform-arg (cdr mrkup))))
+ `(,cmd ,@args))))
;; body:
(if (string? markup-expression)
markup-expression
equivalent to @var{obj}, that is, for a music expression, a
@code{(make-music ...)} form."
(cond (;; markup expression
- (markup? obj)
- (markup-expression->make-markup obj))
- (;; music expression
- (ly:music? obj)
- `(make-music
- ',(ly:music-property obj 'name)
- ,@(apply append (map (lambda (prop)
+ (markup? obj)
+ (markup-expression->make-markup obj))
+ (;; music expression
+ (ly:music? obj)
+ `(make-music
+ ',(ly:music-property obj 'name)
+ ,@(apply append (map (lambda (prop)
`(',(car prop)
- ,(music->make-music (cdr prop))))
+ ,(music->make-music (cdr prop))))
(remove (lambda (prop)
(eqv? (car prop) 'origin))
(ly:music-mutable-properties obj))))))
- (;; moment
- (ly:moment? obj)
- `(ly:make-moment ,(ly:moment-main-numerator obj)
- ,(ly:moment-main-denominator obj)
- ,(ly:moment-grace-numerator obj)
- ,(ly:moment-grace-denominator obj)))
- (;; note duration
- (ly:duration? obj)
- `(ly:make-duration ,(ly:duration-log obj)
- ,(ly:duration-dot-count obj)
- ,(ly:duration-scale obj)))
- (;; note pitch
- (ly:pitch? obj)
- `(ly:make-pitch ,(ly:pitch-octave obj)
- ,(ly:pitch-notename obj)
- ,(ly:pitch-alteration obj)))
- (;; scheme procedure
- (procedure? obj)
- (or (procedure-name obj) obj))
- (;; a symbol (avoid having an unquoted symbol)
- (symbol? obj)
- `',obj)
- (;; an empty list (avoid having an unquoted empty list)
- (null? obj)
- `'())
- (;; a proper list
- (list? obj)
- `(list ,@(map music->make-music obj)))
- (;; a pair
- (pair? obj)
- `(cons ,(music->make-music (car obj))
- ,(music->make-music (cdr obj))))
- (else
- obj)))
+ (;; moment
+ (ly:moment? obj)
+ `(ly:make-moment ,(ly:moment-main-numerator obj)
+ ,(ly:moment-main-denominator obj)
+ ,(ly:moment-grace-numerator obj)
+ ,(ly:moment-grace-denominator obj)))
+ (;; note duration
+ (ly:duration? obj)
+ `(ly:make-duration ,(ly:duration-log obj)
+ ,(ly:duration-dot-count obj)
+ ,(ly:duration-scale obj)))
+ (;; note pitch
+ (ly:pitch? obj)
+ `(ly:make-pitch ,(ly:pitch-octave obj)
+ ,(ly:pitch-notename obj)
+ ,(ly:pitch-alteration obj)))
+ (;; scheme procedure
+ (procedure? obj)
+ (or (procedure-name obj) obj))
+ (;; a symbol (avoid having an unquoted symbol)
+ (symbol? obj)
+ `',obj)
+ (;; an empty list (avoid having an unquoted empty list)
+ (null? obj)
+ `'())
+ (;; a proper list
+ (list? obj)
+ `(list ,@(map music->make-music obj)))
+ (;; a pair
+ (pair? obj)
+ `(cons ,(music->make-music (car obj))
+ ,(music->make-music (cdr obj))))
+ (else
+ obj)))
(use-modules (ice-9 pretty-print))
(define*-public (display-scheme-music obj #:optional (port (current-output-port)))
(scm display-lily))
(define*-public (display-lily-music expr parser #:optional (port (current-output-port))
- #:key force-duration)
+ #:key force-duration)
"Display the music expression using LilyPond syntax"
(memoize-clef-names supported-clefs)
(parameterize ((*indent* 0)
- (*previous-duration* (ly:make-duration 2))
- (*force-duration* force-duration))
- (display (music->lily-string expr parser) port)
- (newline port)))
+ (*previous-duration* (ly:make-duration 2))
+ (*force-duration* force-duration))
+ (display (music->lily-string expr parser) port)
+ (newline port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
The number of dots in the shifted music may not be less than zero."
(let ((d (ly:music-property music 'duration)))
(if (ly:duration? d)
- (let* ((cp (ly:duration-scale d))
- (nd (ly:make-duration
+ (let* ((cp (ly:duration-scale d))
+ (nd (ly:make-duration
(+ shift (ly:duration-log d))
(max 0 (+ dot (ly:duration-dot-count d)))
- cp)))
- (set! (ly:music-property music 'duration) nd)))
+ cp)))
+ (set! (ly:music-property music 'duration) nd)))
music))
(define-public (shift-duration-log music shift dot)
(music-map (lambda (x) (shift-one-duration-log x shift dot))
- music))
+ music))
(define-public (make-repeat name times main alts)
"Create a repeat music expression, with all properties initialized
;; NoteEvent or a non-expanded chord-repetition
;; We just take anything that actually sports an announced duration.
(if (ly:duration? (ly:music-property music 'duration))
- (ly:music-property music 'duration)
- (let loop ((elts (if (ly:music? (ly:music-property music 'element))
- (list (ly:music-property music 'element))
- (ly:music-property music 'elements))))
- (and (pair? elts)
- (let ((dur (first-note-duration (car elts))))
- (if (ly:duration? dur)
- dur
- (loop (cdr elts))))))))
+ (ly:music-property music 'duration)
+ (let loop ((elts (if (ly:music? (ly:music-property music 'element))
+ (list (ly:music-property music 'element))
+ (ly:music-property music 'elements))))
+ (and (pair? elts)
+ (let ((dur (first-note-duration (car elts))))
+ (if (ly:duration? dur)
+ dur
+ (loop (cdr elts))))))))
(let ((talts (if (< times (length alts))
- (begin
- (ly:warning (_ "More alternatives than repeats. Junking excess alternatives"))
- (take alts times))
- alts))
- (r (make-repeated-music name)))
+ (begin
+ (ly:warning (_ "More alternatives than repeats. Junking excess alternatives"))
+ (take alts times))
+ alts))
+ (r (make-repeated-music name)))
(set! (ly:music-property r 'element) main)
(set! (ly:music-property r 'repeat-count) (max times 1))
(set! (ly:music-property r 'elements) talts)
(if (and (equal? name "tremolo")
- (pair? (extract-named-music main '(EventChord NoteEvent))))
- ;; This works for single-note and multi-note tremolos!
- (let* ((children (if (music-is-of-type? main 'sequential-music)
- ;; \repeat tremolo n { ... }
- (length (extract-named-music main '(EventChord
- NoteEvent)))
- ;; \repeat tremolo n c4
- 1))
- ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
- (dots (1- (logcount (* times children))))
- ;; The remaining missing multiplicator to scale the notes by
- ;; times * children
- (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
- (shift (- (ly:intlog2 (floor mult))))
- (note-duration (first-note-duration r))
- (duration-log (if (ly:duration? note-duration)
- (ly:duration-log note-duration)
- 1))
- (tremolo-type (ash 1 duration-log)))
- (set! (ly:music-property r 'tremolo-type) tremolo-type)
- (if (not (and (integer? mult) (= (logcount mult) 1)))
- (ly:music-warning
- main
- (ly:format (_ "invalid tremolo repeat count: ~a") times)))
- ;; Adjust the time of the notes
- (ly:music-compress r (ly:make-moment 1 children))
- ;; Adjust the displayed note durations
- (shift-duration-log r shift dots))
- r)))
+ (pair? (extract-named-music main '(EventChord NoteEvent))))
+ ;; This works for single-note and multi-note tremolos!
+ (let* ((children (if (music-is-of-type? main 'sequential-music)
+ ;; \repeat tremolo n { ... }
+ (length (extract-named-music main '(EventChord
+ NoteEvent)))
+ ;; \repeat tremolo n c4
+ 1))
+ ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
+ (dots (1- (logcount (* times children))))
+ ;; The remaining missing multiplicator to scale the notes by
+ ;; times * children
+ (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
+ (shift (- (ly:intlog2 (floor mult))))
+ (note-duration (first-note-duration r))
+ (duration-log (if (ly:duration? note-duration)
+ (ly:duration-log note-duration)
+ 1))
+ (tremolo-type (ash 1 duration-log)))
+ (set! (ly:music-property r 'tremolo-type) tremolo-type)
+ (if (not (and (integer? mult) (= (logcount mult) 1)))
+ (ly:music-warning
+ main
+ (ly:format (_ "invalid tremolo repeat count: ~a") times)))
+ ;; Adjust the time of the notes
+ (ly:music-compress r (ly:make-moment 1 children))
+ ;; Adjust the displayed note durations
+ (shift-duration-log r shift dots))
+ r)))
(define (calc-repeat-slash-count music)
"Given the child-list @var{music} in @code{PercentRepeatMusic},
if durations in @var{music} vary, allowing slash beats and double-percent
beats to be distinguished."
(let* ((durs (map duration-of-note
- (extract-named-music music '(EventChord NoteEvent
- RestEvent SkipEvent))))
- (first-dur (car durs)))
+ (extract-named-music music '(EventChord NoteEvent
+ RestEvent SkipEvent))))
+ (first-dur (car durs)))
(if (every (lambda (d) (equal? d first-dur)) durs)
- (max (- (ly:duration-log first-dur) 2) 1)
- 0)))
+ (max (- (ly:duration-log first-dur) 2) 1)
+ 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; clusters.
"Replace @code{NoteEvents} by @code{ClusterNoteEvents}."
(if (eq? (ly:music-property music 'name) 'NoteEvent)
(make-music 'ClusterNoteEvent
- 'pitch (ly:music-property music 'pitch)
- 'duration (ly:music-property music 'duration))
+ 'pitch (ly:music-property music 'pitch)
+ 'duration (ly:music-property music 'duration))
music))
(define-public (notes-to-clusters music)
"Replace all repeats with unfolded repeats."
(let ((es (ly:music-property music 'elements))
- (e (ly:music-property music 'element)))
+ (e (ly:music-property music 'element)))
(if (music-is-of-type? music 'repeated-music)
- (let* ((props (ly:music-mutable-properties music))
- (old-name (ly:music-property music 'name))
- (flattened (flatten-alist props)))
- (set! music (apply make-music (cons 'UnfoldedRepeatedMusic
- flattened)))
-
- (if (and (equal? old-name 'TremoloRepeatedMusic)
- (pair? (extract-named-music e '(EventChord NoteEvent))))
- ;; This works for single-note and multi-note tremolos!
- (let* ((children (if (music-is-of-type? e 'sequential-music)
- ;; \repeat tremolo n { ... }
- (length (extract-named-music e '(EventChord
- NoteEvent)))
- ;; \repeat tremolo n c4
- 1))
- (times (ly:music-property music 'repeat-count))
-
- ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
- (dots (1- (logcount (* times children))))
- ;; The remaining missing multiplicator to scale the notes by
- ;; times * children
- (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
- (shift (- (ly:intlog2 (floor mult)))))
-
- ;; Adjust the time of the notes
- (ly:music-compress music (ly:make-moment children 1))
- ;; Adjust the displayed note durations
- (shift-duration-log music (- shift) (- dots))))))
+ (let* ((props (ly:music-mutable-properties music))
+ (old-name (ly:music-property music 'name))
+ (flattened (flatten-alist props)))
+ (set! music (apply make-music (cons 'UnfoldedRepeatedMusic
+ flattened)))
+
+ (if (and (equal? old-name 'TremoloRepeatedMusic)
+ (pair? (extract-named-music e '(EventChord NoteEvent))))
+ ;; This works for single-note and multi-note tremolos!
+ (let* ((children (if (music-is-of-type? e 'sequential-music)
+ ;; \repeat tremolo n { ... }
+ (length (extract-named-music e '(EventChord
+ NoteEvent)))
+ ;; \repeat tremolo n c4
+ 1))
+ (times (ly:music-property music 'repeat-count))
+
+ ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
+ (dots (1- (logcount (* times children))))
+ ;; The remaining missing multiplicator to scale the notes by
+ ;; times * children
+ (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
+ (shift (- (ly:intlog2 (floor mult)))))
+
+ ;; Adjust the time of the notes
+ (ly:music-compress music (ly:make-moment children 1))
+ ;; Adjust the displayed note durations
+ (shift-duration-log music (- shift) (- dots))))))
(if (pair? es)
- (set! (ly:music-property music 'elements)
- (map unfold-repeats es)))
+ (set! (ly:music-property music 'elements)
+ (map unfold-repeats es)))
(if (ly:music? e)
- (set! (ly:music-property music 'element)
- (unfold-repeats e)))
+ (set! (ly:music-property music 'element)
+ (unfold-repeats e)))
music))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Make a @code{Music} expression that sets @var{gprop} to @var{val} in
@var{grob}. Does a pop first, i.e., this is not an override."
(make-music 'OverrideProperty
- 'symbol grob
- 'grob-property gprop
- 'grob-value val
- 'pop-first #t))
+ 'symbol grob
+ 'grob-property gprop
+ 'grob-value val
+ 'pop-first #t))
(define-public (make-grob-property-override grob gprop val)
"Make a @code{Music} expression that overrides @var{gprop} to @var{val}
in @var{grob}."
(make-music 'OverrideProperty
- 'symbol grob
- 'grob-property gprop
- 'grob-value val))
+ 'symbol grob
+ 'grob-property gprop
+ 'grob-value val))
(define-public (make-grob-property-revert grob gprop)
"Revert the grob property @var{gprop} for @var{grob}."
(make-music 'RevertProperty
- 'symbol grob
- 'grob-property gprop))
+ 'symbol grob
+ 'grob-property gprop))
(define direction-polyphonic-grobs
'(AccidentalSuggestion
(make-sequential-music
(append
(map (lambda (x) (make-grob-property-set x 'direction
- (if (odd? n) -1 1)))
- direction-polyphonic-grobs)
+ (if (odd? n) -1 1)))
+ direction-polyphonic-grobs)
(list
(make-property-set 'graceSettings
- ;; TODO: take this from voicedGraceSettings or similar.
- '((Voice Stem font-size -3)
- (Voice Flag font-size -3)
- (Voice NoteHead font-size -3)
- (Voice TabNoteHead font-size -4)
- (Voice Dots font-size -3)
- (Voice Stem length-fraction 0.8)
- (Voice Stem no-stem-extend #t)
- (Voice Beam beam-thickness 0.384)
- (Voice Beam length-fraction 0.8)
- (Voice Accidental font-size -4)
- (Voice AccidentalCautionary font-size -4)
- (Voice Script font-size -3)
- (Voice Fingering font-size -8)
- (Voice StringNumber font-size -8)))
+ ;; TODO: take this from voicedGraceSettings or similar.
+ '((Voice Stem font-size -3)
+ (Voice Flag font-size -3)
+ (Voice NoteHead font-size -3)
+ (Voice TabNoteHead font-size -4)
+ (Voice Dots font-size -3)
+ (Voice Stem length-fraction 0.8)
+ (Voice Stem no-stem-extend #t)
+ (Voice Beam beam-thickness 0.384)
+ (Voice Beam length-fraction 0.8)
+ (Voice Accidental font-size -4)
+ (Voice AccidentalCautionary font-size -4)
+ (Voice Script font-size -3)
+ (Voice Fingering font-size -8)
+ (Voice StringNumber font-size -8)))
(make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))))))
(make-sequential-music
(append
(map (lambda (x) (make-grob-property-override x 'direction
- (if (odd? n) -1 1)))
- direction-polyphonic-grobs)
+ (if (odd? n) -1 1)))
+ direction-polyphonic-grobs)
(list
(make-property-set 'graceSettings
- ;; TODO: take this from voicedGraceSettings or similar.
- '((Voice Stem font-size -3)
- (Voice Flag font-size -3)
- (Voice NoteHead font-size -3)
- (Voice TabNoteHead font-size -4)
- (Voice Dots font-size -3)
- (Voice Stem length-fraction 0.8)
- (Voice Stem no-stem-extend #t)
- (Voice Beam beam-thickness 0.384)
- (Voice Beam length-fraction 0.8)
- (Voice Accidental font-size -4)
- (Voice AccidentalCautionary font-size -4)
- (Voice Script font-size -3)
- (Voice Fingering font-size -8)
- (Voice StringNumber font-size -8)))
+ ;; TODO: take this from voicedGraceSettings or similar.
+ '((Voice Stem font-size -3)
+ (Voice Flag font-size -3)
+ (Voice NoteHead font-size -3)
+ (Voice TabNoteHead font-size -4)
+ (Voice Dots font-size -3)
+ (Voice Stem length-fraction 0.8)
+ (Voice Stem no-stem-extend #t)
+ (Voice Beam beam-thickness 0.384)
+ (Voice Beam length-fraction 0.8)
+ (Voice Accidental font-size -4)
+ (Voice AccidentalCautionary font-size -4)
+ (Voice Script font-size -3)
+ (Voice Fingering font-size -8)
+ (Voice StringNumber font-size -8)))
(make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2))
(make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4))))))
(make-sequential-music
(append
(map (lambda (x) (make-grob-property-revert x 'direction))
- direction-polyphonic-grobs)
+ direction-polyphonic-grobs)
(list (make-property-unset 'graceSettings)
- (make-grob-property-revert 'NoteColumn 'horizontal-shift)
- (make-grob-property-revert 'MultiMeasureRest 'staff-position)))))
+ (make-grob-property-revert 'NoteColumn 'horizontal-shift)
+ (make-grob-property-revert 'MultiMeasureRest 'staff-position)))))
(define-safe-public (context-spec-music m context #:optional id)
"Add \\context CONTEXT = ID to M."
(let ((cm (make-music 'ContextSpeccedMusic
- 'element m
- 'context-type context)))
+ 'element m
+ 'context-type context)))
(if (string? id)
- (set! (ly:music-property cm 'context-id) id))
+ (set! (ly:music-property cm 'context-id) id))
cm))
(define-public (descend-to-context m context)
(define-public (make-non-relative-music mus)
(make-music 'UnrelativableMusic
- 'element mus))
+ 'element mus))
(define-public (make-apply-context func)
(make-music 'ApplyContext
- 'procedure func))
+ 'procedure func))
(define-public (make-sequential-music elts)
(make-music 'SequentialMusic
- 'elements elts))
+ 'elements elts))
(define-public (make-simultaneous-music elts)
(make-music 'SimultaneousMusic
- 'elements elts))
+ 'elements elts))
(define-safe-public (make-event-chord elts)
(make-music 'EventChord
- 'elements elts))
+ 'elements elts))
(define-public (make-skip-music dur)
(make-music 'SkipMusic
- 'duration dur))
+ 'duration dur))
(define-public (make-grace-music music)
(make-music 'GraceMusic
- 'element music))
+ 'element music))
;;;;;;;;;;;;;;;;
;; mmrest
(define-public (make-multi-measure-rest duration location)
(make-music 'MultiMeasureRestMusic
- 'origin location
- 'duration duration))
+ 'origin location
+ 'duration duration))
(define-public (make-property-set sym val)
(make-music 'PropertySet
- 'symbol sym
- 'value val))
+ 'symbol sym
+ 'value val))
(define-public (make-property-unset sym)
(make-music 'PropertyUnset
- 'symbol sym))
+ 'symbol sym))
(define-safe-public (make-articulation name)
(make-music 'ArticulationEvent
- 'articulation-type name))
+ 'articulation-type name))
(define-public (make-lyric-event string duration)
(make-music 'LyricEvent
- 'duration duration
- 'text string))
+ 'duration duration
+ 'text string))
(define-safe-public (make-span-event type span-dir)
(make-music type
- 'span-direction span-dir))
+ 'span-direction span-dir))
(define-public (override-head-style heads style)
"Override style for @var{heads} to @var{style}."
(make-sequential-music
- (if (pair? heads)
- (map (lambda (h)
+ (if (pair? heads)
+ (map (lambda (h)
(make-grob-property-override h 'style style))
- heads)
- (list (make-grob-property-override heads 'style style)))))
+ heads)
+ (list (make-grob-property-override heads 'style style)))))
(define-public (revert-head-style heads)
"Revert style for @var{heads}."
(make-sequential-music
- (if (pair? heads)
- (map (lambda (h)
+ (if (pair? heads)
+ (map (lambda (h)
(make-grob-property-revert h 'style))
- heads)
- (list (make-grob-property-revert heads 'style)))))
+ heads)
+ (list (make-grob-property-revert heads 'style)))))
(define-public (style-note-heads heads style music)
- "Set @var{style} for all @var{heads} in @var{music}. Works both
+ "Set @var{style} for all @var{heads} in @var{music}. Works both
inside of and outside of chord construct."
;; are we inside a <...>?
(if (eq? (ly:music-property music 'name) 'NoteEvent)
music)
;; not in <...>, so use overrides
(make-sequential-music
- (list
- (override-head-style heads style)
- music
- (revert-head-style heads)))))
+ (list
+ (override-head-style heads style)
+ music
+ (revert-head-style heads)))))
- (define-public (set-mus-properties! m alist)
+(define-public (set-mus-properties! m alist)
"Set all of @var{alist} as properties of @var{m}."
(if (pair? alist)
(begin
- (set! (ly:music-property m (caar alist)) (cdar alist))
- (set-mus-properties! m (cdr alist)))))
+ (set! (ly:music-property m (caar alist)) (cdar alist))
+ (set-mus-properties! m (cdr alist)))))
(define-public (music-separator? m)
"Is @var{m} a separator?"
;;; expanding repeat chords
(define-public (copy-repeat-chord original-chord repeat-chord duration
- event-types)
+ event-types)
"Copies all events in @var{event-types} (be sure to include
@code{rhythmic-events}) from @var{original-chord} over to
@var{repeat-chord} with their articulations filtered as well. Any
(define (keep-element? m)
(any (lambda (t) (music-is-of-type? m t))
- event-types))
+ event-types))
(define origin (ly:music-property repeat-chord 'origin #f))
(define (set-origin! l)
(if origin
- (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l))
+ (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l))
l)
(for-each
(lambda (field)
(for-each (lambda (e)
- (for-each (lambda (x)
- (set! event-types (delq x event-types)))
- (ly:music-property e 'types)))
- (ly:music-property repeat-chord field)))
+ (for-each (lambda (x)
+ (set! event-types (delq x event-types)))
+ (ly:music-property e 'types)))
+ (ly:music-property repeat-chord field)))
'(elements articulations))
;; now treat the elements
(set! (ly:music-property repeat-chord 'elements)
- (let ((elts
- (set-origin! (ly:music-deep-copy
- (filter keep-element?
- (ly:music-property original-chord
- 'elements))))))
- (for-each
- (lambda (m)
- (let ((arts (ly:music-property m 'articulations)))
- (if (pair? arts)
- (set! (ly:music-property m 'articulations)
- (set-origin! (filter! keep-element? arts))))
- (if (ly:duration? (ly:music-property m 'duration))
- (set! (ly:music-property m 'duration) duration))))
- elts)
- (append! elts (ly:music-property repeat-chord 'elements))))
+ (let ((elts
+ (set-origin! (ly:music-deep-copy
+ (filter keep-element?
+ (ly:music-property original-chord
+ 'elements))))))
+ (for-each
+ (lambda (m)
+ (let ((arts (ly:music-property m 'articulations)))
+ (if (pair? arts)
+ (set! (ly:music-property m 'articulations)
+ (set-origin! (filter! keep-element? arts))))
+ (if (ly:duration? (ly:music-property m 'duration))
+ (set! (ly:music-property m 'duration) duration))))
+ elts)
+ (append! elts (ly:music-property repeat-chord 'elements))))
(let ((arts (filter keep-element?
- (ly:music-property original-chord
- 'articulations))))
+ (ly:music-property original-chord
+ 'articulations))))
(if (pair? arts)
- (set! (ly:music-property repeat-chord 'articulations)
- (append!
- (set-origin! (ly:music-deep-copy arts))
- (ly:music-property repeat-chord 'articulations))))))
+ (set! (ly:music-property repeat-chord 'articulations)
+ (append!
+ (set-origin! (ly:music-deep-copy arts))
+ (ly:music-property repeat-chord 'articulations))))))
(define-public (expand-repeat-chords! event-types music)
respective predecessor chord."
(let loop ((music music) (last-chord #f))
(if (music-is-of-type? music 'event-chord)
- (let ((chord-repeat (ly:music-property music 'duration)))
- (cond
- ((not (ly:duration? chord-repeat))
- (if (any (lambda (m) (ly:duration?
- (ly:music-property m 'duration)))
- (ly:music-property music 'elements))
- music
- last-chord))
- (last-chord
- (set! (ly:music-property music 'duration) '())
- (copy-repeat-chord last-chord music chord-repeat event-types)
- music)
- (else
- (ly:music-warning music (_ "Bad chord repetition"))
- #f)))
- (let ((elt (ly:music-property music 'element)))
- (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord)
- (ly:music-property music 'elements)))))
+ (let ((chord-repeat (ly:music-property music 'duration)))
+ (cond
+ ((not (ly:duration? chord-repeat))
+ (if (any (lambda (m) (ly:duration?
+ (ly:music-property m 'duration)))
+ (ly:music-property music 'elements))
+ music
+ last-chord))
+ (last-chord
+ (set! (ly:music-property music 'duration) '())
+ (copy-repeat-chord last-chord music chord-repeat event-types)
+ music)
+ (else
+ (ly:music-warning music (_ "Bad chord repetition"))
+ #f)))
+ (let ((elt (ly:music-property music 'element)))
+ (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord)
+ (ly:music-property music 'elements)))))
music)
;;; splitting chords into voices.
(if (null? lst)
'()
(cons (context-spec-music
- (make-sequential-music
- (list (make-voice-props-set number)
- (make-simultaneous-music (car lst))))
- 'Bottom (number->string (1+ number)))
- (voicify-list (cdr lst) (1+ number)))))
+ (make-sequential-music
+ (list (make-voice-props-set number)
+ (make-simultaneous-music (car lst))))
+ 'Bottom (number->string (1+ number)))
+ (voicify-list (cdr lst) (1+ number)))))
(define (voicify-chord ch)
"Split the parts of a chord into different Voices using separator"
(let ((es (ly:music-property ch 'elements)))
(set! (ly:music-property ch 'elements)
- (voicify-list (split-list-by-separator es music-separator?) 0))
+ (voicify-list (split-list-by-separator es music-separator?) 0))
ch))
(define-public (voicify-music m)
(if (not (ly:music? m))
(ly:error (_ "music expected: ~S") m))
(let ((es (ly:music-property m 'elements))
- (e (ly:music-property m 'element)))
+ (e (ly:music-property m 'element)))
(if (pair? es)
- (set! (ly:music-property m 'elements) (map voicify-music es)))
+ (set! (ly:music-property m 'elements) (map voicify-music es)))
(if (ly:music? e)
- (set! (ly:music-property m 'element) (voicify-music e)))
+ (set! (ly:music-property m 'element) (voicify-music e)))
(if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic)
- (any music-separator? es))
- (set! m (context-spec-music (voicify-chord m) 'Staff)))
+ (any music-separator? es))
+ (set! m (context-spec-music (voicify-chord m) 'Staff)))
m))
(define-public (empty-music)
@code{\\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1))}"
(let ((meta (ly:grob-property grob 'meta)))
(if (equal? (assoc-get 'name meta) grob-name)
- (set! (ly:grob-property grob symbol) val))))
+ (set! (ly:grob-property grob symbol) val))))
(define-public (skip->rest mus)
@code{SkipEvent}. Useful for extracting parts from crowded scores."
(if (memq (ly:music-property mus 'name) '(SkipEvent SkipMusic))
- (make-music 'RestEvent 'duration (ly:music-property mus 'duration))
- mus))
+ (make-music 'RestEvent 'duration (ly:music-property mus 'duration))
+ mus))
(define-public (music-has-type music type)
(define (vector-extend v x)
"Make a new vector consisting of V, with X added to the end."
(let* ((n (vector-length v))
- (nv (make-vector (+ n 1) '())))
+ (nv (make-vector (+ n 1) '())))
(vector-move-left! v 0 n nv 0)
(vector-set! nv n x)
nv))
"Set @var{sym}=@var{val} for @var{grob} in @var{context-name}."
(define (set-prop context)
(let* ((where (ly:context-property-where-defined context 'graceSettings))
- (current (ly:context-property where 'graceSettings))
- (new-settings (append current
- (list (list context-name grob sym val)))))
+ (current (ly:context-property where 'graceSettings))
+ (new-settings (append current
+ (list (list context-name grob sym val)))))
(ly:context-set-property! where 'graceSettings new-settings)))
(context-spec-music (make-apply-context set-prop) 'Voice))
(eq? (caddr property) sym)))
(define (delete-prop context)
(let* ((where (ly:context-property-where-defined context 'graceSettings))
- (current (ly:context-property where 'graceSettings))
+ (current (ly:context-property where 'graceSettings))
(prop-settings (filter
- (lambda(x) (sym-grob-context? x sym grob context-name))
- current))
- (new-settings current))
+ (lambda(x) (sym-grob-context? x sym grob context-name))
+ current))
+ (new-settings current))
(for-each (lambda(x)
- (set! new-settings (delete x new-settings)))
- prop-settings)
+ (set! new-settings (delete x new-settings)))
+ prop-settings)
(ly:context-set-property! where 'graceSettings new-settings)))
(context-spec-music (make-apply-context delete-prop) 'Voice))
`(define-music-function (parser location music) (ly:music?)
,@docstring
(make-music 'GraceMusic
- 'origin location
- 'element (make-music 'SequentialMusic
- 'elements (list (ly:music-deep-copy ,start)
- music
- (ly:music-deep-copy ,stop))))))
+ 'origin location
+ 'element (make-music 'SequentialMusic
+ 'elements (list (ly:music-deep-copy ,start)
+ music
+ (ly:music-deep-copy ,stop))))))
(defmacro-public define-syntax-function (type args signature . body)
"Helper macro for `ly:make-music-function'.
result."
(set! signature (map (lambda (pred)
- (if (pair? pred)
- `(cons ,(car pred)
- ,(and (pair? (cdr pred)) (cadr pred)))
- pred))
- (cons type signature)))
+ (if (pair? pred)
+ `(cons ,(car pred)
+ ,(and (pair? (cdr pred)) (cadr pred)))
+ pred))
+ (cons type signature)))
(if (and (pair? body) (pair? (car body)) (eqv? '_i (caar body)))
;; When the music function definition contains a i10n doc string,
;; (_i "doc string"), keep the literal string only
(let ((docstring (cadar body))
- (body (cdr body)))
- `(ly:make-music-function (list ,@signature)
- (lambda ,args
- ,docstring
- ,@body)))
+ (body (cdr body)))
+ `(ly:make-music-function (list ,@signature)
+ (lambda ,args
+ ,docstring
+ ,@body)))
`(ly:make-music-function (list ,@signature)
- (lambda ,args
- ,@body))))
+ (lambda ,args
+ ,@body))))
(defmacro-public define-music-function rest
"Defining macro returning music functions.
(if (vector? (ly:music-property quote-music 'quoted-events))
(let* ((dir (ly:music-property quote-music 'quoted-voice-direction))
- (clef (ly:music-property quote-music 'quoted-music-clef #f))
- (main-voice (case dir ((1) 1) ((-1) 0) (else #f)))
- (cue-voice (and main-voice (- 1 main-voice)))
- (main-music (ly:music-property quote-music 'element))
- (return-value quote-music))
-
- (if main-voice
- (set! (ly:music-property quote-music 'element)
- (make-sequential-music
- (list
- (make-voice-props-override main-voice)
- main-music
- (make-voice-props-revert)))))
-
- ;; if we have stem dirs, change both quoted and main music
- ;; to have opposite stems.
-
- ;; cannot context-spec Quote-music, since context
- ;; for the quotes is determined in the iterator.
-
- (make-sequential-music
- (delq! #f
- (list
- (and clef (make-cue-clef-set clef))
-
- ;; Need to establish CueVoice context even in #CENTER case
- (context-spec-music
- (if cue-voice
- (make-voice-props-override cue-voice)
- (make-music 'Music))
- 'CueVoice "cue")
- quote-music
- (and cue-voice
- (context-spec-music
- (make-voice-props-revert) 'CueVoice "cue"))
- (and clef (make-cue-clef-unset))))))
+ (clef (ly:music-property quote-music 'quoted-music-clef #f))
+ (main-voice (case dir ((1) 1) ((-1) 0) (else #f)))
+ (cue-voice (and main-voice (- 1 main-voice)))
+ (main-music (ly:music-property quote-music 'element))
+ (return-value quote-music))
+
+ (if main-voice
+ (set! (ly:music-property quote-music 'element)
+ (make-sequential-music
+ (list
+ (make-voice-props-override main-voice)
+ main-music
+ (make-voice-props-revert)))))
+
+ ;; if we have stem dirs, change both quoted and main music
+ ;; to have opposite stems.
+
+ ;; cannot context-spec Quote-music, since context
+ ;; for the quotes is determined in the iterator.
+
+ (make-sequential-music
+ (delq! #f
+ (list
+ (and clef (make-cue-clef-set clef))
+
+ ;; Need to establish CueVoice context even in #CENTER case
+ (context-spec-music
+ (if cue-voice
+ (make-voice-props-override cue-voice)
+ (make-music 'Music))
+ 'CueVoice "cue")
+ quote-music
+ (and cue-voice
+ (context-spec-music
+ (make-voice-props-revert) 'CueVoice "cue"))
+ (and clef (make-cue-clef-unset))))))
quote-music))
(define-public ((quote-substitute quote-tab) music)
(let* ((quoted-name (ly:music-property music 'quoted-music-name))
- (quoted-vector (and (string? quoted-name)
- (hash-ref quote-tab quoted-name #f))))
+ (quoted-vector (and (string? quoted-name)
+ (hash-ref quote-tab quoted-name #f))))
(if (string? quoted-name)
- (if (vector? quoted-vector)
- (begin
- (set! (ly:music-property music 'quoted-events) quoted-vector)
- (set! (ly:music-property music 'iterator-ctor)
- ly:quote-iterator::constructor))
- (ly:music-warning music (ly:format (_ "cannot find quoted music: `~S'") quoted-name))))
+ (if (vector? quoted-vector)
+ (begin
+ (set! (ly:music-property music 'quoted-events) quoted-vector)
+ (set! (ly:music-property music 'iterator-ctor)
+ ly:quote-iterator::constructor))
+ (ly:music-warning music (ly:format (_ "cannot find quoted music: `~S'") quoted-name))))
music))
(define found #f)
(define (signal m)
(if (and (ly:music? m)
- (eq? (ly:music-property m 'error-found) #t))
- (set! found #t)))
+ (eq? (ly:music-property m 'error-found) #t))
+ (set! found #t)))
(for-each signal (ly:music-property music 'elements))
(signal (ly:music-property music 'element))
(define (precompute-music-length music)
(set! (ly:music-property music 'length)
- (ly:music-length music))
+ (ly:music-length music))
music)
(define-public (make-duration-of-length moment)
- "Make duration of the given @code{moment} length."
- (ly:make-duration 0 0
- (ly:moment-main-numerator moment)
- (ly:moment-main-denominator moment)))
+ "Make duration of the given @code{moment} length."
+ (ly:make-duration 0 0
+ (ly:moment-main-numerator moment)
+ (ly:moment-main-denominator moment)))
(define (make-skipped moment bool)
- "Depending on BOOL, set or unset skipTypesetting,
+ "Depending on BOOL, set or unset skipTypesetting,
then make SkipMusic of the given MOMENT length, and
then revert skipTypesetting."
- (make-sequential-music
- (list
- (context-spec-music (make-property-set 'skipTypesetting bool)
- 'Score)
- (make-music 'SkipMusic 'duration
- (make-duration-of-length moment))
- (context-spec-music (make-property-set 'skipTypesetting (not bool))
- 'Score))))
+ (make-sequential-music
+ (list
+ (context-spec-music (make-property-set 'skipTypesetting bool)
+ 'Score)
+ (make-music 'SkipMusic 'duration
+ (make-duration-of-length moment))
+ (context-spec-music (make-property-set 'skipTypesetting (not bool))
+ 'Score))))
(define (skip-as-needed music parser)
"Replace MUSIC by
((show-last (ly:parser-lookup parser 'showLastLength))
(show-first (ly:parser-lookup parser 'showFirstLength))
(show-last-length (and (ly:music? show-last)
- (ly:music-length show-last)))
+ (ly:music-length show-last)))
(show-first-length (and (ly:music? show-first)
- (ly:music-length show-first)))
+ (ly:music-length show-first)))
(orig-length (ly:music-length music)))
;;FIXME: if using either showFirst- or showLastLength,
(define-public toplevel-music-functions
(list
(lambda (music parser) (expand-repeat-chords!
- (cons 'rhythmic-event
- (ly:parser-lookup parser '$chord-repeat-events))
- music))
+ (cons 'rhythmic-event
+ (ly:parser-lookup parser '$chord-repeat-events))
+ music))
(lambda (music parser) (voicify-music music))
(lambda (x parser) (music-map music-check-error x))
(lambda (x parser) (music-map precompute-music-length x))
(lambda (x parser)
(skip-as-needed x parser)
- )))
+ )))
;;;;;;;;;;
;;; general purpose music functions
(define (shift-octave pitch octave-shift)
(_i "Add @var{octave-shift} to the octave of @var{pitch}.")
(ly:make-pitch
- (+ (ly:pitch-octave pitch) octave-shift)
- (ly:pitch-notename pitch)
- (ly:pitch-alteration pitch)))
+ (+ (ly:pitch-octave pitch) octave-shift)
+ (ly:pitch-notename pitch)
+ (ly:pitch-alteration pitch)))
;;;;;;;;;;;;;;;;;
(define (apply-durations lyric-music durations)
(define (apply-duration music)
(if (and (not (equal? (ly:music-length music) ZERO-MOMENT))
- (ly:duration? (ly:music-property music 'duration)))
- (begin
- (set! (ly:music-property music 'duration) (car durations))
- (set! durations (cdr durations)))))
+ (ly:duration? (ly:music-property music 'duration)))
+ (begin
+ (set! (ly:music-property music 'duration) (car durations))
+ (set! durations (cdr durations)))))
(music-map apply-duration lyric-music))
Returns @code{#f} or the reason for the invalidation, a symbol."
(let* ((def (if (pair? alteration-def)
- (car alteration-def)
- alteration-def)))
+ (car alteration-def)
+ alteration-def)))
(and (symbol? def) def)))
(define (extract-alteration alteration-def)
(cond ((number? alteration-def)
- alteration-def)
- ((pair? alteration-def)
- (car alteration-def))
- (else 0)))
+ alteration-def)
+ ((pair? alteration-def)
+ (car alteration-def))
+ (else 0)))
(define (check-pitch-against-signature context pitch barnum laziness octaveness)
"Checks the need for an accidental and a @q{restore} accidental against
@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and
specifies whether accidentals should be canceled in different octaves."
(let* ((ignore-octave (cond ((equal? octaveness 'any-octave) #t)
- ((equal? octaveness 'same-octave) #f)
- (else
- (ly:warning (_ "Unknown octaveness type: ~S ") octaveness)
- (ly:warning (_ "Defaulting to 'any-octave."))
- #t)))
- (key-sig (ly:context-property context 'keySignature))
- (local-key-sig (ly:context-property context 'localKeySignature))
- (notename (ly:pitch-notename pitch))
- (octave (ly:pitch-octave pitch))
- (pitch-handle (cons octave notename))
- (need-restore #f)
- (need-accidental #f)
- (previous-alteration #f)
- (from-other-octaves #f)
- (from-same-octave (assoc-get pitch-handle local-key-sig))
- (from-key-sig (or (assoc-get notename local-key-sig)
-
- ;; If no key signature match is found from localKeySignature, we may have a custom
- ;; type with octave-specific entries of the form ((octave . pitch) alteration)
- ;; instead of (pitch . alteration). Since this type cannot coexist with entries in
- ;; localKeySignature, try extracting from keySignature instead.
- (assoc-get pitch-handle key-sig))))
+ ((equal? octaveness 'same-octave) #f)
+ (else
+ (ly:warning (_ "Unknown octaveness type: ~S ") octaveness)
+ (ly:warning (_ "Defaulting to 'any-octave."))
+ #t)))
+ (key-sig (ly:context-property context 'keySignature))
+ (local-key-sig (ly:context-property context 'localKeySignature))
+ (notename (ly:pitch-notename pitch))
+ (octave (ly:pitch-octave pitch))
+ (pitch-handle (cons octave notename))
+ (need-restore #f)
+ (need-accidental #f)
+ (previous-alteration #f)
+ (from-other-octaves #f)
+ (from-same-octave (assoc-get pitch-handle local-key-sig))
+ (from-key-sig (or (assoc-get notename local-key-sig)
+
+ ;; If no key signature match is found from localKeySignature, we may have a custom
+ ;; type with octave-specific entries of the form ((octave . pitch) alteration)
+ ;; instead of (pitch . alteration). Since this type cannot coexist with entries in
+ ;; localKeySignature, try extracting from keySignature instead.
+ (assoc-get pitch-handle key-sig))))
;; loop through localKeySignature to search for a notename match from other octaves
(let loop ((l local-key-sig))
(if (pair? l)
- (let ((entry (car l)))
- (if (and (pair? (car entry))
- (= (cdar entry) notename))
- (set! from-other-octaves (cdr entry))
- (loop (cdr l))))))
+ (let ((entry (car l)))
+ (if (and (pair? (car entry))
+ (= (cdar entry) notename))
+ (set! from-other-octaves (cdr entry))
+ (loop (cdr l))))))
;; find previous alteration-def for comparison with pitch
(cond
;; from same octave?
((and (not ignore-octave)
- from-same-octave
- (recent-enough? barnum from-same-octave laziness))
+ from-same-octave
+ (recent-enough? barnum from-same-octave laziness))
(set! previous-alteration from-same-octave))
;; from any octave?
((and ignore-octave
- from-other-octaves
- (recent-enough? barnum from-other-octaves laziness))
+ from-other-octaves
+ (recent-enough? barnum from-other-octaves laziness))
(set! previous-alteration from-other-octaves))
;; not recent enough, extract from key signature/local key signature
(set! previous-alteration from-key-sig)))
(if (accidental-invalid? previous-alteration)
- (set! need-accidental #t)
+ (set! need-accidental #t)
- (let* ((prev-alt (extract-alteration previous-alteration))
- (this-alt (ly:pitch-alteration pitch)))
+ (let* ((prev-alt (extract-alteration previous-alteration))
+ (this-alt (ly:pitch-alteration pitch)))
- (if (not (= this-alt prev-alt))
- (begin
- (set! need-accidental #t)
- (if (and (not (= this-alt 0))
- (and (< (abs this-alt) (abs prev-alt))
- (> (* prev-alt this-alt) 0)))
- (set! need-restore #t))))))
+ (if (not (= this-alt prev-alt))
+ (begin
+ (set! need-accidental #t)
+ (if (and (not (= this-alt 0))
+ (and (< (abs this-alt) (abs prev-alt))
+ (> (* prev-alt this-alt) 0)))
+ (set! need-restore #t))))))
(cons need-restore need-accidental)))
For convenience, returns @code{0} if entry is @code{#f}."
(if entry
(if (number? (cdr entry))
- (cdr entry)
- (cadr entry))
+ (cdr entry)
+ (cadr entry))
0))
(define-public (find-pitch-entry keysig pitch accept-global accept-local)
If no matching entry is found, @var{#f} is returned."
(and (pair? keysig)
(let* ((entry (car keysig))
- (entryoct (key-entry-octave entry))
- (entrynn (key-entry-notename entry))
- (nn (ly:pitch-notename pitch)))
- (if (and (equal? nn entrynn)
- (or (not entryoct)
- (= entryoct (ly:pitch-octave pitch)))
- (if (key-entry-bar-number entry)
- accept-local
- accept-global))
- entry
- (find-pitch-entry (cdr keysig) pitch accept-global accept-local)))))
+ (entryoct (key-entry-octave entry))
+ (entrynn (key-entry-notename entry))
+ (nn (ly:pitch-notename pitch)))
+ (if (and (equal? nn entrynn)
+ (or (not entryoct)
+ (= entryoct (ly:pitch-octave pitch)))
+ (if (key-entry-bar-number entry)
+ accept-local
+ accept-global))
+ entry
+ (find-pitch-entry (cdr keysig) pitch accept-global accept-local)))))
(define-public (neo-modern-accidental-rule context pitch barnum measurepos)
"An accidental rule that typesets an accidental if it differs from the
staff line. This rule should not be used alone because it does neither
look at bar lines nor different accidentals at the same note name."
(let* ((keysig (ly:context-property context 'localKeySignature))
- (entry (find-pitch-entry keysig pitch #t #t)))
+ (entry (find-pitch-entry keysig pitch #t #t)))
(if (not entry)
- (cons #f #f)
- (let* ((global-entry (find-pitch-entry keysig pitch #t #f))
- (key-acc (key-entry-alteration global-entry))
- (acc (ly:pitch-alteration pitch))
- (entrymp (key-entry-measure-position entry))
- (entrybn (key-entry-bar-number entry)))
- (cons #f (not (or (equal? acc key-acc)
- (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))))
+ (cons #f #f)
+ (let* ((global-entry (find-pitch-entry keysig pitch #t #f))
+ (key-acc (key-entry-alteration global-entry))
+ (acc (ly:pitch-alteration pitch))
+ (entrymp (key-entry-measure-position entry))
+ (entrybn (key-entry-bar-number entry)))
+ (cons #f (not (or (equal? acc key-acc)
+ (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))))
(define-public (teaching-accidental-rule context pitch barnum measurepos)
"An accidental rule that typesets a cautionary accidental if it is
included in the key signature @emph{and} does not directly follow a note
on the same staff line."
(let* ((keysig (ly:context-property context 'localKeySignature))
- (entry (find-pitch-entry keysig pitch #t #t)))
+ (entry (find-pitch-entry keysig pitch #t #t)))
(if (not entry)
- (cons #f #f)
- (let* ((entrymp (key-entry-measure-position entry))
- (entrybn (key-entry-bar-number entry)))
- (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))
+ (cons #f #f)
+ (let* ((entrymp (key-entry-measure-position entry))
+ (entrybn (key-entry-bar-number entry)))
+ (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))
(define-public (set-accidentals-properties extra-natural
- auto-accs auto-cauts
- context)
+ auto-accs auto-cauts
+ context)
(context-spec-music
(make-sequential-music
(append (if (boolean? extra-natural)
- (list (make-property-set 'extraNatural extra-natural))
- '())
- (list (make-property-set 'autoAccidentals auto-accs)
- (make-property-set 'autoCautionaries auto-cauts))))
+ (list (make-property-set 'extraNatural extra-natural))
+ '())
+ (list (make-property-set 'autoAccidentals auto-accs)
+ (make-property-set 'autoCautionaries auto-cauts))))
context))
(define-public (set-accidental-style style . rest)
to @code{Staff}, except for piano styles, which use @code{GrandStaff}
as a context."
(let ((context (if (pair? rest)
- (car rest) 'Staff))
- (pcontext (if (pair? rest)
- (car rest) 'GrandStaff)))
+ (car rest) 'Staff))
+ (pcontext (if (pair? rest)
+ (car rest) 'GrandStaff)))
(cond
- ;; accidentals as they were common in the 18th century.
- ((equal? style 'default)
- (set-accidentals-properties #t
- `(Staff ,(make-accidental-rule 'same-octave 0))
- '()
- context))
- ;; accidentals from one voice do NOT get canceled in other voices
- ((equal? style 'voice)
- (set-accidentals-properties #t
- `(Voice ,(make-accidental-rule 'same-octave 0))
- '()
- context))
- ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century.
- ;; This includes all the default accidentals, but accidentals also needs canceling
- ;; in other octaves and in the next measure.
- ((equal? style 'modern)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- '()
- context))
- ;; the accidentals that Stone adds to the old standard as cautionaries
- ((equal? style 'modern-cautionary)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0))
- `(Staff ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- context))
- ;; same as modern, but accidentals different from the key signature are always
- ;; typeset - unless they directly follow a note of the same pitch.
- ((equal? style 'neo-modern)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule)
- '()
- context))
- ((equal? style 'neo-modern-cautionary)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0))
- `(Staff ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule)
- context))
- ((equal? style 'neo-modern-voice)
- (set-accidentals-properties #f
- `(Voice ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule
- Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule)
- '()
- context))
- ((equal? style 'neo-modern-voice-cautionary)
- (set-accidentals-properties #f
- `(Voice ,(make-accidental-rule 'same-octave 0))
- `(Voice ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule
- Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- ,neo-modern-accidental-rule)
- context))
- ;; Accidentals as they were common in dodecaphonic music with no tonality.
- ;; Each note gets one accidental.
- ((equal? style 'dodecaphonic)
- (set-accidentals-properties #f
- `(Staff ,(lambda (c p bn mp) '(#f . #t)))
- '()
- context))
- ;; Multivoice accidentals to be read both by musicians playing one voice
- ;; and musicians playing all voices.
- ;; Accidentals are typeset for each voice, but they ARE canceled across voices.
- ((equal? style 'modern-voice)
- (set-accidentals-properties #f
- `(Voice ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- '()
- context))
- ;; same as modernVoiceAccidental eccept that all special accidentals are typeset
- ;; as cautionaries
- ((equal? style 'modern-voice-cautionary)
- (set-accidentals-properties #f
- `(Voice ,(make-accidental-rule 'same-octave 0))
- `(Voice ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- context))
- ;; stone's suggestions for accidentals on grand staff.
- ;; Accidentals are canceled across the staves in the same grand staff as well
- ((equal? style 'piano)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0)
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- GrandStaff
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- '()
- pcontext))
- ((equal? style 'piano-cautionary)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0))
- `(Staff ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1)
- GrandStaff
- ,(make-accidental-rule 'any-octave 0)
- ,(make-accidental-rule 'same-octave 1))
- pcontext))
-
- ;; same as modern, but cautionary accidentals are printed for all sharp or flat
- ;; tones specified by the key signature.
- ((equal? style 'teaching)
- (set-accidentals-properties #f
- `(Staff ,(make-accidental-rule 'same-octave 0))
- `(Staff ,(make-accidental-rule 'same-octave 1)
- ,teaching-accidental-rule)
- context))
-
- ;; do not set localKeySignature when a note alterated differently from
- ;; localKeySignature is found.
- ;; Causes accidentals to be printed at every note instead of
- ;; remembered for the duration of a measure.
- ;; accidentals not being remembered, causing accidentals always to
- ;; be typeset relative to the time signature
- ((equal? style 'forget)
- (set-accidentals-properties '()
- `(Staff ,(make-accidental-rule 'same-octave -1))
- '()
- context))
- ;; Do not reset the key at the start of a measure. Accidentals will be
- ;; printed only once and are in effect until overridden, possibly many
- ;; measures later.
- ((equal? style 'no-reset)
- (set-accidentals-properties '()
- `(Staff ,(make-accidental-rule 'same-octave #t))
- '()
- context))
- (else
- (ly:warning (_ "unknown accidental style: ~S") style)
- (make-sequential-music '())))))
+ ;; accidentals as they were common in the 18th century.
+ ((equal? style 'default)
+ (set-accidentals-properties #t
+ `(Staff ,(make-accidental-rule 'same-octave 0))
+ '()
+ context))
+ ;; accidentals from one voice do NOT get canceled in other voices
+ ((equal? style 'voice)
+ (set-accidentals-properties #t
+ `(Voice ,(make-accidental-rule 'same-octave 0))
+ '()
+ context))
+ ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century.
+ ;; This includes all the default accidentals, but accidentals also needs canceling
+ ;; in other octaves and in the next measure.
+ ((equal? style 'modern)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ '()
+ context))
+ ;; the accidentals that Stone adds to the old standard as cautionaries
+ ((equal? style 'modern-cautionary)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0))
+ `(Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ context))
+ ;; same as modern, but accidentals different from the key signature are always
+ ;; typeset - unless they directly follow a note of the same pitch.
+ ((equal? style 'neo-modern)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ '()
+ context))
+ ((equal? style 'neo-modern-cautionary)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0))
+ `(Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ context))
+ ((equal? style 'neo-modern-voice)
+ (set-accidentals-properties #f
+ `(Voice ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule
+ Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ '()
+ context))
+ ((equal? style 'neo-modern-voice-cautionary)
+ (set-accidentals-properties #f
+ `(Voice ,(make-accidental-rule 'same-octave 0))
+ `(Voice ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule
+ Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ context))
+ ;; Accidentals as they were common in dodecaphonic music with no tonality.
+ ;; Each note gets one accidental.
+ ((equal? style 'dodecaphonic)
+ (set-accidentals-properties #f
+ `(Staff ,(lambda (c p bn mp) '(#f . #t)))
+ '()
+ context))
+ ;; Multivoice accidentals to be read both by musicians playing one voice
+ ;; and musicians playing all voices.
+ ;; Accidentals are typeset for each voice, but they ARE canceled across voices.
+ ((equal? style 'modern-voice)
+ (set-accidentals-properties #f
+ `(Voice ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ '()
+ context))
+ ;; same as modernVoiceAccidental eccept that all special accidentals are typeset
+ ;; as cautionaries
+ ((equal? style 'modern-voice-cautionary)
+ (set-accidentals-properties #f
+ `(Voice ,(make-accidental-rule 'same-octave 0))
+ `(Voice ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ context))
+ ;; stone's suggestions for accidentals on grand staff.
+ ;; Accidentals are canceled across the staves in the same grand staff as well
+ ((equal? style 'piano)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ GrandStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ '()
+ pcontext))
+ ((equal? style 'piano-cautionary)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0))
+ `(Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ GrandStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ pcontext))
+
+ ;; same as modern, but cautionary accidentals are printed for all sharp or flat
+ ;; tones specified by the key signature.
+ ((equal? style 'teaching)
+ (set-accidentals-properties #f
+ `(Staff ,(make-accidental-rule 'same-octave 0))
+ `(Staff ,(make-accidental-rule 'same-octave 1)
+ ,teaching-accidental-rule)
+ context))
+
+ ;; do not set localKeySignature when a note alterated differently from
+ ;; localKeySignature is found.
+ ;; Causes accidentals to be printed at every note instead of
+ ;; remembered for the duration of a measure.
+ ;; accidentals not being remembered, causing accidentals always to
+ ;; be typeset relative to the time signature
+ ((equal? style 'forget)
+ (set-accidentals-properties '()
+ `(Staff ,(make-accidental-rule 'same-octave -1))
+ '()
+ context))
+ ;; Do not reset the key at the start of a measure. Accidentals will be
+ ;; printed only once and are in effect until overridden, possibly many
+ ;; measures later.
+ ((equal? style 'no-reset)
+ (set-accidentals-properties '()
+ `(Staff ,(make-accidental-rule 'same-octave #t))
+ '()
+ context))
+ (else
+ (ly:warning (_ "unknown accidental style: ~S") style)
+ (make-sequential-music '())))))
(define-public (invalidate-alterations context)
"Invalidate alterations in @var{context}.
Entries that conform with the current key signature are not invalidated."
(let* ((keysig (ly:context-property context 'keySignature)))
(set! (ly:context-property context 'localKeySignature)
- (map-in-order
- (lambda (entry)
- (let* ((localalt (key-entry-alteration entry)))
- (if (or (accidental-invalid? localalt)
- (not (key-entry-bar-number entry))
- (= localalt
- (key-entry-alteration
- (find-pitch-entry
- keysig
- (ly:make-pitch (key-entry-octave entry)
- (key-entry-notename entry)
- 0)
- #t #t))))
- entry
- (cons (car entry) (cons 'clef (cddr entry))))))
- (ly:context-property context 'localKeySignature)))))
+ (map-in-order
+ (lambda (entry)
+ (let* ((localalt (key-entry-alteration entry)))
+ (if (or (accidental-invalid? localalt)
+ (not (key-entry-bar-number entry))
+ (= localalt
+ (key-entry-alteration
+ (find-pitch-entry
+ keysig
+ (ly:make-pitch (key-entry-octave entry)
+ (key-entry-notename entry)
+ 0)
+ #t #t))))
+ entry
+ (cons (car entry) (cons 'clef (cddr entry))))))
+ (ly:context-property context 'localKeySignature)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (skip-of-length mus)
"Create a skip of exactly the same length as @var{mus}."
(let* ((skip
- (make-music
- 'SkipEvent
- 'duration (ly:make-duration 0 0))))
+ (make-music
+ 'SkipEvent
+ 'duration (ly:make-duration 0 0))))
(make-event-chord (list (ly:music-compress skip (ly:music-length mus))))))
"Create a multi-measure rest of exactly the same length as @var{mus}."
(let* ((skip
- (make-multi-measure-rest
- (ly:make-duration 0 0) '())))
+ (make-multi-measure-rest
+ (ly:make-duration 0 0) '())))
(ly:music-compress skip (ly:music-length mus))
skip))
(define-public (pitch-of-note event-chord)
(let ((evs (filter (lambda (x)
- (music-has-type x 'note-event))
- (ly:music-property event-chord 'elements))))
+ (music-has-type x 'note-event))
+ (ly:music-property event-chord 'elements))))
(and (pair? evs)
- (ly:music-property (car evs) 'pitch))))
+ (ly:music-property (car evs) 'pitch))))
(define-public (duration-of-note event-chord)
(cond
((pair? event-chord)
(or (duration-of-note (car event-chord))
- (duration-of-note (cdr event-chord))))
+ (duration-of-note (cdr event-chord))))
((ly:music? event-chord)
(let ((dur (ly:music-property event-chord 'duration)))
(if (ly:duration? dur)
- dur
- (duration-of-note (ly:music-property event-chord 'elements)))))
+ dur
+ (duration-of-note (ly:music-property event-chord 'elements)))))
(else #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
and only recurse if this returns @code{#f}."
(let loop ((music music))
(or (map? music)
- (let ((elt (ly:music-property music 'element))
- (elts (ly:music-property music 'elements))
- (arts (ly:music-property music 'articulations)))
- (if (ly:music? elt)
- (set! (ly:music-property music 'element)
- (loop elt)))
- (if (pair? elts)
- (set! (ly:music-property music 'elements)
- (map loop elts)))
- (if (pair? arts)
- (set! (ly:music-property music 'articulations)
- (map loop arts)))
- music))))
+ (let ((elt (ly:music-property music 'element))
+ (elts (ly:music-property music 'elements))
+ (arts (ly:music-property music 'articulations)))
+ (if (ly:music? elt)
+ (set! (ly:music-property music 'element)
+ (loop elt)))
+ (if (pair? elts)
+ (set! (ly:music-property music 'elements)
+ (map loop elts)))
+ (if (pair? arts)
+ (set! (ly:music-property music 'articulations)
+ (map loop arts)))
+ music))))
(define-public (for-some-music stop? music)
"Walk through @var{music}, process all elements calling @var{stop?}
and only recurse if this returns @code{#f}."
(let loop ((music music))
(if (not (stop? music))
- (let ((elt (ly:music-property music 'element)))
- (if (ly:music? elt)
- (loop elt))
- (for-each loop (ly:music-property music 'elements))
- (for-each loop (ly:music-property music 'articulations))))))
+ (let ((elt (ly:music-property music 'element)))
+ (if (ly:music? elt)
+ (loop elt))
+ (for-each loop (ly:music-property music 'elements))
+ (for-each loop (ly:music-property music 'articulations))))))
(define-public (fold-some-music pred? proc init music)
"This works recursively on music like @code{fold} does on a list,
The top @var{music} is processed using @var{init} for @samp{previous}."
(let loop ((music music) (previous init))
(if (pred? music)
- (proc music previous)
- (fold loop
- (fold loop
- (let ((elt (ly:music-property music 'element)))
- (if (null? elt)
- previous
- (loop elt previous)))
- (ly:music-property music 'elements))
- (ly:music-property music 'articulations)))))
+ (proc music previous)
+ (fold loop
+ (fold loop
+ (let ((elt (ly:music-property music 'element)))
+ (if (null? elt)
+ previous
+ (loop elt previous)))
+ (ly:music-property music 'elements))
+ (ly:music-property music 'articulations)))))
(define-public (extract-music music pred?)
"Return a flat list of all music matching @var{pred?} inside of
music
(if (cheap-list? type)
(lambda (m)
- (any (lambda (t) (music-is-of-type? m t)) type))
+ (any (lambda (t) (music-is-of-type? m t)) type))
(lambda (m) (music-is-of-type? m type)))))
(define*-public (event-chord-wrap! music #:optional parser)
(map-some-music
(lambda (m)
(cond ((music-is-of-type? m 'event-chord)
- (if (pair? (ly:music-property m 'articulations))
- (begin
- (set! (ly:music-property m 'elements)
- (append (ly:music-property m 'elements)
- (ly:music-property m 'articulations)))
- (set! (ly:music-property m 'articulations) '())))
- m)
- ((music-is-of-type? m 'rhythmic-event)
- (let ((arts (ly:music-property m 'articulations)))
- (if (pair? arts)
- (set! (ly:music-property m 'articulations) '()))
- (make-event-chord (cons m arts))))
- (else #f)))
+ (if (pair? (ly:music-property m 'articulations))
+ (begin
+ (set! (ly:music-property m 'elements)
+ (append (ly:music-property m 'elements)
+ (ly:music-property m 'articulations)))
+ (set! (ly:music-property m 'articulations) '())))
+ m)
+ ((music-is-of-type? m 'rhythmic-event)
+ (let ((arts (ly:music-property m 'articulations)))
+ (if (pair? arts)
+ (set! (ly:music-property m 'articulations) '()))
+ (make-event-chord (cons m arts))))
+ (else #f)))
(if parser
(expand-repeat-chords!
- (cons 'rhythmic-event
- (ly:parser-lookup parser '$chord-repeat-events))
- music)
+ (cons 'rhythmic-event
+ (ly:parser-lookup parser '$chord-repeat-events))
+ music)
music)))
(define-public (event-chord-notes event-chord)
"Return a list of all notes from @var{event-chord}."
(filter
- (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name)))
- (ly:music-property event-chord 'elements)))
+ (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name)))
+ (ly:music-property event-chord 'elements)))
(define-public (event-chord-pitches event-chord)
"Return a list of all pitches from @var{event-chord}."
(define (close-enough? x y)
"Values are close enough to ignore the difference"
- (< (abs (- x y)) 0.0001))
+ (< (abs (- x y)) 0.0001))
(define (extent-combine extents)
"Combine a list of extents"
;; The root is always connectable to itself
(or (eq? root stem)
(and
- ;; Horizontal positions of the stems must be almost the same
- (close-enough? (car (ly:grob-extent root ref X))
- (car (ly:grob-extent stem ref X)))
- ;; The stem must be in the direction away from the root's notehead
- (positive? (* (ly:grob-property root 'direction)
+ ;; Horizontal positions of the stems must be almost the same
+ (close-enough? (car (ly:grob-extent root ref X))
+ (car (ly:grob-extent stem ref X)))
+ ;; The stem must be in the direction away from the root's notehead
+ (positive? (* (ly:grob-property root 'direction)
(- (car (ly:grob-extent stem ref Y))
- (car (ly:grob-extent root ref Y))))))))
+ (car (ly:grob-extent root ref Y))))))))
(define (stem-span-stencil span)
"Connect stems if we have at least one stem connectable to the root"
(let* ((system (ly:grob-system span))
- (root (ly:grob-parent span X))
- (stems (filter (stem-connectable? system root)
- (ly:grob-object span 'stems))))
- (if (<= 2 (length stems))
- (let* ((yextents (map (lambda (st)
- (ly:grob-extent st system Y)) stems))
- (yextent (extent-combine yextents))
- (layout (ly:grob-layout root))
- (blot (ly:output-def-lookup layout 'blot-diameter)))
- ;; Hide spanned stems
- (map (lambda (st)
- (set! (ly:grob-property st 'stencil) #f))
- stems)
- ;; Draw a nice looking stem with rounded corners
- (ly:round-filled-box (ly:grob-extent root root X) yextent blot))
- ;; Nothing to connect, don't draw the span
- #f)))
+ (root (ly:grob-parent span X))
+ (stems (filter (stem-connectable? system root)
+ (ly:grob-object span 'stems))))
+ (if (<= 2 (length stems))
+ (let* ((yextents (map (lambda (st)
+ (ly:grob-extent st system Y)) stems))
+ (yextent (extent-combine yextents))
+ (layout (ly:grob-layout root))
+ (blot (ly:output-def-lookup layout 'blot-diameter)))
+ ;; Hide spanned stems
+ (map (lambda (st)
+ (set! (ly:grob-property st 'stencil) #f))
+ stems)
+ ;; Draw a nice looking stem with rounded corners
+ (ly:round-filled-box (ly:grob-extent root root X) yextent blot))
+ ;; Nothing to connect, don't draw the span
+ #f)))
(define ((make-stem-span! stems trans) root)
"Create a stem span as a child of the cross-staff stem (the root)"
(define-public (cross-staff-connect stem)
"Set cross-staff property of the stem to this function to connect it to
other stems automatically"
- #t)
+ #t)
(define (stem-is-root? stem)
"Check if automatic connecting of the stem was requested. Stems connected
;; Cannot do extensive checks here, just make sure there are at least
;; two stems at this musical moment
(if (<= 2 (length stems))
- (let ((roots (filter stem-is-root? stems)))
- (map (make-stem-span! stems trans) roots))))
+ (let ((roots (filter stem-is-root? stems)))
+ (map (make-stem-span! stems trans) roots))))
(define-public (Span_stem_engraver ctx)
"Connect cross-staff stems to the stems above in the system"
(let ((stems '()))
(make-engraver
- ;; Record all stems for the given moment
- (acknowledgers
- ((stem-interface trans grob source)
- (set! stems (cons grob stems))))
- ;; Process stems and reset the stem list to empty
- ((process-acknowledged trans)
- (make-stem-spans! ctx stems trans)
- (set! stems '())))))
+ ;; Record all stems for the given moment
+ (acknowledgers
+ ((stem-interface trans grob source)
+ (set! stems (cons grob stems))))
+ ;; Process stems and reset the stem list to empty
+ ((process-acknowledged trans)
+ (make-stem-spans! ctx stems trans)
+ (set! stems '())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following is used by the alterBroken function.
(let* ((orig (ly:grob-original grob))
(siblings (ly:spanner-broken-into orig)))
- (define (helper sibs arg)
- (if (null? arg)
- arg
- (if (eq? (car sibs) grob)
- (car arg)
- (helper (cdr sibs) (cdr arg)))))
+ (define (helper sibs arg)
+ (if (null? arg)
+ arg
+ (if (eq? (car sibs) grob)
+ (car arg)
+ (helper (cdr sibs) (cdr arg)))))
- (if (>= (length siblings) 2)
- (helper siblings arg)
- (car arg))))
+ (if (>= (length siblings) 2)
+ (helper siblings arg)
+ (car arg))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; measure counter
;; a system in the event that a MeasureCounter spanner is broken
(all-cols (ly:grob-array->list (ly:grob-object refp 'columns)))
(all-cols
- (filter
- (lambda (col) (eq? #t (ly:grob-property col 'non-musical)))
- all-cols))
+ (filter
+ (lambda (col) (eq? #t (ly:grob-property col 'non-musical)))
+ all-cols))
(left-bound
- (if (or (null? siblings) ; spanner is unbroken
- (eq? grob (car siblings))) ; or the first piece
- (car bounds)
- (car all-cols)))
+ (if (or (null? siblings) ; spanner is unbroken
+ (eq? grob (car siblings))) ; or the first piece
+ (car bounds)
+ (car all-cols)))
(right-bound
- (if (or (null? siblings)
- (eq? grob (car (reverse siblings))))
- (car (reverse bounds))
- (car (reverse all-cols))))
+ (if (or (null? siblings)
+ (eq? grob (car (reverse siblings))))
+ (car (reverse bounds))
+ (car (reverse all-cols))))
(elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements)))
(elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements)))
(break-alignment-L
- (filter
- (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
- elts-L))
+ (filter
+ (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
+ elts-L))
(break-alignment-R
- (filter
- (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
- elts-R))
+ (filter
+ (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
+ elts-R))
(break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X))
(break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X))
(num (markup (number->string (ly:grob-property grob 'count-from))))
(num
- (if (or (null? siblings)
- (eq? grob (car siblings)))
- num
- (make-parenthesize-markup num)))
+ (if (or (null? siblings)
+ (eq? grob (car siblings)))
+ num
+ (make-parenthesize-markup num)))
(num (grob-interpret-markup grob num))
(num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X)))
(num
- (ly:stencil-translate-axis
- num
- (+ (interval-length break-alignment-L-ext)
- (* 0.5
- (- (car break-alignment-R-ext)
- (cdr break-alignment-L-ext))))
- X)))
+ (ly:stencil-translate-axis
+ num
+ (+ (interval-length break-alignment-L-ext)
+ (* 0.5
+ (- (car break-alignment-R-ext)
+ (cdr break-alignment-L-ext))))
+ X)))
num))
(define-public (print-circled-text-callback grob)
(grob-interpret-markup grob (make-circle-markup
- (ly:grob-property grob 'text))))
+ (ly:grob-property grob 'text))))
(define-public (event-cause grob)
(let ((cause (ly:grob-property grob 'cause)))
(define-public (grob-interpret-markup grob text)
(let* ((layout (ly:grob-layout grob))
- (defs (ly:output-def-lookup layout 'text-font-defaults))
- (props (ly:grob-alist-chain grob defs)))
+ (defs (ly:output-def-lookup layout 'text-font-defaults))
+ (props (ly:grob-alist-chain grob defs)))
(ly:text-interface::interpret-markup layout props text)))
(define-public grob::unpure-horizontal-skylines-from-stencil
(ly:make-unpure-pure-container
- ly:grob::horizontal-skylines-from-stencil
- ly:grob::pure-simple-horizontal-skylines-from-extents))
+ ly:grob::horizontal-skylines-from-stencil
+ ly:grob::pure-simple-horizontal-skylines-from-extents))
(define-public grob::always-horizontal-skylines-from-stencil
(ly:make-unpure-pure-container
- ly:grob::horizontal-skylines-from-stencil))
+ ly:grob::horizontal-skylines-from-stencil))
(define-public grob::unpure-vertical-skylines-from-stencil
(ly:make-unpure-pure-container
- ly:grob::vertical-skylines-from-stencil
- ly:grob::pure-simple-vertical-skylines-from-extents))
+ ly:grob::vertical-skylines-from-stencil
+ ly:grob::pure-simple-vertical-skylines-from-extents))
(define-public grob::always-vertical-skylines-from-stencil
(ly:make-unpure-pure-container
- ly:grob::vertical-skylines-from-stencil))
+ ly:grob::vertical-skylines-from-stencil))
(define-public grob::always-vertical-skylines-from-element-stencils
(ly:make-unpure-pure-container
- ly:grob::vertical-skylines-from-element-stencils
- ly:grob::pure-vertical-skylines-from-element-stencils))
+ ly:grob::vertical-skylines-from-element-stencils
+ ly:grob::pure-vertical-skylines-from-element-stencils))
(define-public grob::always-horizontal-skylines-from-element-stencils
(ly:make-unpure-pure-container
- ly:grob::horizontal-skylines-from-element-stencils
- ly:grob::pure-horizontal-skylines-from-element-stencils))
+ ly:grob::horizontal-skylines-from-element-stencils
+ ly:grob::pure-horizontal-skylines-from-element-stencils))
;; Using this as a callback for a grob's Y-extent promises
;; that the grob's stencil does not depend on line-spacing.
(let* ((layout (ly:grob-layout grob))
(line-thickness (ly:output-def-lookup layout 'line-thickness)))
- line-thickness))
+ line-thickness))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; beam slope
(ly:grob-array->list stems)
'())))
(for-each
- (lambda (g)
- (ly:grob-set-property! g 'stem-begin-position 0)
- (ly:grob-set-property! g 'length 0))
- stems-grobs)
+ (lambda (g)
+ (ly:grob-set-property! g 'stem-begin-position 0)
+ (ly:grob-set-property! g 'length 0))
+ stems-grobs)
pos))
;; calculates each slope of a broken beam individually
quant2))
(factor (/ (atan (abs slope1)) PI-OVER-TWO))
(base (cons-map
- (lambda (x)
- (+ (* (x quant1) (- 1 factor))
- (* (x quant2) factor)))
- (cons car cdr))))
+ (lambda (x)
+ (+ (* (x quant1) (- 1 factor))
+ (* (x quant2) factor)))
+ (cons car cdr))))
(ly:beam::quanting grob base #f)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public side-position-interface::y-aligned-side
(ly:make-unpure-pure-container
- ly:side-position-interface::y-aligned-side
- ly:side-position-interface::pure-y-aligned-side))
+ ly:side-position-interface::y-aligned-side
+ ly:side-position-interface::pure-y-aligned-side))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; self-alignment stuff
(define-public self-alignment-interface::y-aligned-on-self
(ly:make-unpure-pure-container
- ly:self-alignment-interface::y-aligned-on-self
- ly:self-alignment-interface::pure-y-aligned-on-self))
+ ly:self-alignment-interface::y-aligned-on-self
+ ly:self-alignment-interface::pure-y-aligned-on-self))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; staff symbol
(define-public (note-head::calc-kievan-duration-log grob)
(min 3
(ly:duration-log
- (ly:event-property (event-cause grob) 'duration))))
+ (ly:event-property (event-cause grob) 'duration))))
(define-public (note-head::calc-duration-log grob)
(min 2
(ly:duration-log
- (ly:event-property (event-cause grob) 'duration))))
+ (ly:event-property (event-cause grob) 'duration))))
(define-public (dots::calc-dot-count grob)
(ly:duration-dot-count
(define-public (dots::calc-staff-position grob)
(let* ((head (ly:grob-parent grob Y))
- (log (ly:grob-property head 'duration-log)))
+ (log (ly:grob-property head 'duration-log)))
(cond
((or (not (grob::has-interface head 'rest-interface))
- (not (integer? log))) 0)
+ (not (integer? log))) 0)
((= log 7) 4)
((> log 4) 3)
((= log 0) -1)
((harmonic) "0harmonic")
((harmonic-black) "2harmonic")
((harmonic-mixed) (if (<= log 1) "0harmonic"
- "2harmonic"))
+ "2harmonic"))
((baroque)
;; Oops, I actually would not call this "baroque", but, for
;; backwards compatibility to 1.4, this is supposed to take
;; brevis, longa and maxima from the neo-mensural font and all
;; other note heads from the default font. -- jr
(if (< log 0)
- (string-append (number->string log) "neomensural")
- (number->string log)))
+ (string-append (number->string log) "neomensural")
+ (number->string log)))
((altdefault)
;; Like default, but brevis is drawn with double vertical lines
(if (= log -1)
- (string-append (number->string log) "double")
- (number->string log)))
+ (string-append (number->string log) "double")
+ (number->string log)))
((mensural)
(string-append (number->string log) (symbol->string style)))
((petrucci)
(if (< log 0)
- (string-append (number->string log) "mensural")
- (string-append (number->string log) (symbol->string style))))
+ (string-append (number->string log) "mensural")
+ (string-append (number->string log) (symbol->string style))))
((blackpetrucci)
(if (< log 0)
- (string-append (number->string log) "blackmensural")
- (string-append (number->string log) (symbol->string style))))
+ (string-append (number->string log) "blackmensural")
+ (string-append (number->string log) (symbol->string style))))
((semipetrucci)
(if (< log 0)
- (string-append (number->string log) "semimensural")
- (string-append (number->string log) "petrucci")))
+ (string-append (number->string log) "semimensural")
+ (string-append (number->string log) "petrucci")))
((neomensural)
(string-append (number->string log) (symbol->string style)))
((kievan)
(string-append (number->string log) "kievan"))
(else
(if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
- (symbol->string style)
- (string-append (number->string (max 0 log))
- (symbol->string style))))))
+ (symbol->string style)
+ (string-append (number->string (max 0 log))
+ (symbol->string style))))))
(define-public (note-head::calc-glyph-name grob)
(let* ((style (ly:grob-property grob 'style))
- (log (if (string-match "kievan*" (symbol->string style))
- (min 3 (ly:grob-property grob 'duration-log))
- (min 2 (ly:grob-property grob 'duration-log)))))
+ (log (if (string-match "kievan*" (symbol->string style))
+ (min 3 (ly:grob-property grob 'duration-log))
+ (min 2 (ly:grob-property grob 'duration-log)))))
(select-head-glyph style log)))
(define-public (note-head::brew-ez-stencil grob)
(let* ((log (ly:grob-property grob 'duration-log))
- (pitch (ly:event-property (event-cause grob) 'pitch))
- (pitch-index (ly:pitch-notename pitch))
- (note-names (ly:grob-property grob 'note-names))
- (pitch-string (if (and (vector? note-names)
- (> (vector-length note-names) pitch-index))
- (vector-ref note-names pitch-index)
- (string
- (integer->char
- (+ (modulo (+ pitch-index 2) 7)
- (char->integer #\A))))))
- (staff-space (ly:staff-symbol-staff-space grob))
- (line-thickness (ly:staff-symbol-line-thickness grob))
- (stem (ly:grob-object grob 'stem))
- (stem-thickness (* (if (ly:grob? stem)
- (ly:grob-property stem 'thickness)
- 1.3)
- line-thickness))
- (radius (/ (+ staff-space line-thickness) 2))
- (letter (markup #:center-align #:vcenter pitch-string))
- (filled-circle (markup #:draw-circle radius 0 #t)))
+ (pitch (ly:event-property (event-cause grob) 'pitch))
+ (pitch-index (ly:pitch-notename pitch))
+ (note-names (ly:grob-property grob 'note-names))
+ (pitch-string (if (and (vector? note-names)
+ (> (vector-length note-names) pitch-index))
+ (vector-ref note-names pitch-index)
+ (string
+ (integer->char
+ (+ (modulo (+ pitch-index 2) 7)
+ (char->integer #\A))))))
+ (staff-space (ly:staff-symbol-staff-space grob))
+ (line-thickness (ly:staff-symbol-line-thickness grob))
+ (stem (ly:grob-object grob 'stem))
+ (stem-thickness (* (if (ly:grob? stem)
+ (ly:grob-property stem 'thickness)
+ 1.3)
+ line-thickness))
+ (radius (/ (+ staff-space line-thickness) 2))
+ (letter (markup #:center-align #:vcenter pitch-string))
+ (filled-circle (markup #:draw-circle radius 0 #t)))
(ly:stencil-translate-axis
(grob-interpret-markup
grob
(if (>= log 2)
- (make-combine-markup
- filled-circle
- (make-with-color-markup white letter))
- (make-combine-markup
- (make-combine-markup
- filled-circle
- (make-with-color-markup white (make-draw-circle-markup
- (- radius stem-thickness) 0 #t)))
- letter)))
+ (make-combine-markup
+ filled-circle
+ (make-with-color-markup white letter))
+ (make-combine-markup
+ (make-combine-markup
+ filled-circle
+ (make-with-color-markup white (make-draw-circle-markup
+ (- radius stem-thickness) 0 #t)))
+ letter)))
radius X)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (rhythmic-location->file-string a)
(ly:format "~a.~a.~a"
- (car a)
- (ly:moment-main-numerator (cdr a))
- (ly:moment-main-denominator (cdr a))))
+ (car a)
+ (ly:moment-main-numerator (cdr a))
+ (ly:moment-main-denominator (cdr a))))
(define-public (rhythmic-location->string a)
(ly:format "bar ~a ~a"
- (car a)
- (ly:moment->string (cdr a))))
+ (car a)
+ (ly:moment->string (cdr a))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; break visibility
(define-public (shift-right-at-line-begin g)
"Shift an item to the right, but only at the start of the line."
(if (and (ly:item? g)
- (equal? (ly:item-break-dir g) RIGHT))
+ (equal? (ly:item-break-dir g) RIGHT))
(ly:grob-translate-axis! g 3.5 X)))
(define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
(define-public (pure-from-neighbor-interface::extra-spacing-height grob)
(let* ((height (ly:grob-pure-height grob grob 0 INFINITY-INT))
(from-neighbors (interval-union
- height
- (ly:axis-group-interface::pure-height
- grob
- 0
- INFINITY-INT))))
+ height
+ (ly:axis-group-interface::pure-height
+ grob
+ 0
+ INFINITY-INT))))
(coord-operation - from-neighbors height)))
;; If there are neighbors, we place the height at their midpoint
(ii (interval-intersection esh (cons -1.01 1.01))))
(if (pair? hsb)
(cons (car (if (and (car hsb)
- (ly:grob-property grob 'allow-span-bar))
+ (ly:grob-property grob 'allow-span-bar))
esh ii))
(cdr (if (cdr hsb) esh ii)))
ii)))
(let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
(to-staff (coord-operation -
(interval-widen
- '(0 . 0)
- (ly:staff-symbol-staff-radius grob))
+ '(0 . 0)
+ (ly:staff-symbol-staff-radius grob))
(ly:grob::stencil-height grob))))
(interval-union esh to-staff)))
(let ((ev (event-cause grob)))
(format #f "~a:~a"
- (ly:event-property ev 'denominator)
- (ly:event-property ev 'numerator))))
+ (ly:event-property ev 'denominator)
+ (ly:event-property ev 'numerator))))
;; a formatter function, which is simply a wrapper around an existing
;; tuplet formatter function. It takes the value returned by the given
(let ((txt (if function (function grob) #f)))
(if txt
- (markup txt #:fontsize -5 #:note note UP)
- (markup #:fontsize -5 #:note note UP))))
+ (markup txt #:fontsize -5 #:note note UP)
+ (markup #:fontsize -5 #:note note UP))))
;; Print a tuplet denominator with a different number than the one derived from
;; the actual tuplet fraction
(define-public ((tuplet-number::non-default-tuplet-denominator-text denominator)
- grob)
+ grob)
(number->string (if denominator
- denominator
- (ly:event-property (event-cause grob) 'denominator))))
+ denominator
+ (ly:event-property (event-cause grob) 'denominator))))
;; Print a tuplet fraction with different numbers than the ones derived from
;; the actual tuplet fraction
(define-public ((tuplet-number::non-default-tuplet-fraction-text
- denominator numerator) grob)
+ denominator numerator) grob)
(let* ((ev (event-cause grob))
(den (if denominator denominator (ly:event-property ev 'denominator)))
(num (if numerator numerator (ly:event-property ev 'numerator))))
;; Print a tuplet fraction with note durations appended to the numerator and the
;; denominator
(define-public ((tuplet-number::fraction-with-notes
- denominatornote numeratornote) grob)
+ denominatornote numeratornote) grob)
(let* ((ev (event-cause grob))
(denominator (ly:event-property ev 'denominator))
(numerator (ly:event-property ev 'numerator)))
;; Print a tuplet fraction with note durations appended to the numerator and the
;; denominator
(define-public ((tuplet-number::non-default-fraction-with-notes
- denominator denominatornote numerator numeratornote) grob)
+ denominator denominatornote numerator numeratornote) grob)
(let* ((ev (event-cause grob))
(den (if denominator denominator (ly:event-property ev 'denominator)))
(num (if numerator numerator (ly:event-property ev 'numerator))))
(make-concat-markup (list
- (make-simple-markup (format #f "~a" den))
- (markup #:fontsize -5 #:note denominatornote UP)
- (make-simple-markup " : ")
- (make-simple-markup (format #f "~a" num))
- (markup #:fontsize -5 #:note numeratornote UP)))))
+ (make-simple-markup (format #f "~a" den))
+ (markup #:fontsize -5 #:note denominatornote UP)
+ (make-simple-markup " : ")
+ (make-simple-markup (format #f "~a" num))
+ (markup #:fontsize -5 #:note numeratornote UP)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; key signature
(define-public (key-signature-interface::alteration-positions
- entry c0-position grob)
+ entry c0-position grob)
(let ((step (car entry))
- (alter (cdr entry)))
+ (alter (cdr entry)))
(if (pair? step)
- (list (+ (cdr step) (* (car step) 7) c0-position))
- (let* ((c-position (modulo c0-position 7))
- (positions
- (if (< alter 0)
- ;; See (flat|sharp)-positions in define-grob-properties.scm
- (ly:grob-property grob 'flat-positions '(3))
- (ly:grob-property grob 'sharp-positions '(3))))
- (p (list-ref positions
- (if (< c-position (length positions))
- c-position 0)))
- (max-position (if (pair? p) (cdr p) p))
- (min-position (if (pair? p) (car p) (- max-position 6)))
- (first-position (+ (modulo (- (+ c-position step)
- min-position)
- 7)
- min-position)))
- (define (prepend x l) (if (> x max-position)
- l
- (prepend (+ x 7) (cons x l))))
- (prepend first-position '())))))
+ (list (+ (cdr step) (* (car step) 7) c0-position))
+ (let* ((c-position (modulo c0-position 7))
+ (positions
+ (if (< alter 0)
+ ;; See (flat|sharp)-positions in define-grob-properties.scm
+ (ly:grob-property grob 'flat-positions '(3))
+ (ly:grob-property grob 'sharp-positions '(3))))
+ (p (list-ref positions
+ (if (< c-position (length positions))
+ c-position 0)))
+ (max-position (if (pair? p) (cdr p) p))
+ (min-position (if (pair? p) (car p) (- max-position 6)))
+ (first-position (+ (modulo (- (+ c-position step)
+ min-position)
+ 7)
+ min-position)))
+ (define (prepend x l) (if (> x max-position)
+ l
+ (prepend (+ x 7) (cons x l))))
+ (prepend first-position '())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; annotations
idx
(- n 1))))
(markup #:tiny (helper '("*" "†" "‡" "§" "¶")
- ""
- (remainder int 5)
- (+ 1 (quotient int 5)))))
+ ""
+ (remainder int 5)
+ (+ 1 (quotient int 5)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; accidentals
(define-public accidental-interface::height
(ly:make-unpure-pure-container
- ly:accidental-interface::height
- ly:accidental-interface::pure-height))
+ ly:accidental-interface::height
+ ly:accidental-interface::pure-height))
(define-public cancellation-glyph-name-alist
'((0 . "accidentals.natural")))
(1/2 . "accidentals.mensural1")))
(define-public alteration-kievan-glyph-name-alist
- '((-1/2 . "accidentals.kievanM1")
- (1/2 . "accidentals.kievan1")))
+ '((-1/2 . "accidentals.kievanM1")
+ (1/2 . "accidentals.kievan1")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; * Pitch Trill Heads
(define-public (parentheses-item::calc-parenthesis-stencils grob)
(let* ((font (ly:grob-default-font grob))
- (lp (ly:font-get-glyph font "accidentals.leftparen"))
- (rp (ly:font-get-glyph font "accidentals.rightparen")))
+ (lp (ly:font-get-glyph font "accidentals.leftparen"))
+ (rp (ly:font-get-glyph font "accidentals.rightparen")))
(list lp rp)))
(width 0.5) ; should it be a property?
(angularity 1.5) ; makes angle brackets
(white-padding 0.1) ; should it be a property?
- (lp (ly:stencil-aligned-to
- (ly:stencil-aligned-to
- (make-parenthesis-stencil y-extent
- half-thickness
- (- width)
- angularity)
- Y CENTER)
- X RIGHT))
+ (lp (ly:stencil-aligned-to
+ (ly:stencil-aligned-to
+ (make-parenthesis-stencil y-extent
+ half-thickness
+ (- width)
+ angularity)
+ Y CENTER)
+ X RIGHT))
(lp-x-extent
- (interval-widen (ly:stencil-extent lp X) white-padding))
- (rp (ly:stencil-aligned-to
- (ly:stencil-aligned-to
- (make-parenthesis-stencil y-extent
- half-thickness
- width
- angularity)
- Y CENTER)
- X LEFT))
- (rp-x-extent
- (interval-widen (ly:stencil-extent rp X) white-padding)))
+ (interval-widen (ly:stencil-extent lp X) white-padding))
+ (rp (ly:stencil-aligned-to
+ (ly:stencil-aligned-to
+ (make-parenthesis-stencil y-extent
+ half-thickness
+ width
+ angularity)
+ Y CENTER)
+ X LEFT))
+ (rp-x-extent
+ (interval-widen (ly:stencil-extent rp X) white-padding)))
(set! lp (ly:make-stencil (ly:stencil-expr lp)
lp-x-extent
(ly:stencil-extent lp Y)))
(define (parenthesize-elements grob . rest)
(let* ((refp (if (null? rest)
- grob
- (car rest)))
- (elts (ly:grob-object grob 'elements))
- (x-ext (ly:relative-group-extent elts refp X))
- (stencils (ly:grob-property grob 'stencils))
- (lp (car stencils))
- (rp (cadr stencils))
- (padding (ly:grob-property grob 'padding 0.1)))
+ grob
+ (car rest)))
+ (elts (ly:grob-object grob 'elements))
+ (x-ext (ly:relative-group-extent elts refp X))
+ (stencils (ly:grob-property grob 'stencils))
+ (lp (car stencils))
+ (rp (cadr stencils))
+ (padding (ly:grob-property grob 'padding 0.1)))
(ly:stencil-add
(ly:stencil-translate-axis lp (- (car x-ext) padding) X)
(define-public (parentheses-item::print me)
(let* ((elts (ly:grob-object me 'elements))
- (y-ref (ly:grob-common-refpoint-of-array me elts Y))
- (x-ref (ly:grob-common-refpoint-of-array me elts X))
- (stencil (parenthesize-elements me x-ref))
- (elt-y-ext (ly:relative-group-extent elts y-ref Y))
- (y-center (interval-center elt-y-ext)))
+ (y-ref (ly:grob-common-refpoint-of-array me elts Y))
+ (x-ref (ly:grob-common-refpoint-of-array me elts X))
+ (stencil (parenthesize-elements me x-ref))
+ (elt-y-ext (ly:relative-group-extent elts y-ref Y))
+ (y-center (interval-center elt-y-ext)))
(ly:stencil-translate
stencil
(< (abs (- a b)) 0.01))
(let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
- (left-span (ly:spanner-bound spanner LEFT))
- (dots (if (and (grob::has-interface left-span 'note-head-interface)
- (ly:grob? (ly:grob-object left-span 'dot)))
- (ly:grob-object left-span 'dot) #f))
-
- (right-span (ly:spanner-bound spanner RIGHT))
- (thickness (* (ly:grob-property spanner 'thickness)
- (ly:output-def-lookup (ly:grob-layout spanner)
- 'line-thickness)))
- (padding (ly:grob-property spanner 'padding 0.5))
- (common (ly:grob-common-refpoint right-span
- (ly:grob-common-refpoint spanner
- left-span X)
- X))
- (common-y (ly:grob-common-refpoint spanner left-span Y))
- (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
-
- (left-x (+ padding
- (max
- (interval-end (ly:grob-robust-relative-extent
- left-span common X))
- (if
- (and dots
- (close
- (ly:grob-relative-coordinate dots common-y Y)
- (ly:grob-relative-coordinate spanner common-y Y)))
- (interval-end
- (ly:grob-robust-relative-extent dots common X))
- (- INFINITY-INT)))))
- (right-x (max (- (interval-start
- (ly:grob-robust-relative-extent right-span common X))
- padding)
- (+ left-x minimum-length)))
- (self-x (ly:grob-relative-coordinate spanner common X))
- (dx (- right-x left-x))
- (exp (list 'path thickness
- `(quote
- (rmoveto
- ,(- left-x self-x) 0
-
- rcurveto
- ,(/ dx 3)
- 0
- ,dx ,(* 0.66 delta-y)
- ,dx ,delta-y)))))
+ (left-span (ly:spanner-bound spanner LEFT))
+ (dots (if (and (grob::has-interface left-span 'note-head-interface)
+ (ly:grob? (ly:grob-object left-span 'dot)))
+ (ly:grob-object left-span 'dot) #f))
+
+ (right-span (ly:spanner-bound spanner RIGHT))
+ (thickness (* (ly:grob-property spanner 'thickness)
+ (ly:output-def-lookup (ly:grob-layout spanner)
+ 'line-thickness)))
+ (padding (ly:grob-property spanner 'padding 0.5))
+ (common (ly:grob-common-refpoint right-span
+ (ly:grob-common-refpoint spanner
+ left-span X)
+ X))
+ (common-y (ly:grob-common-refpoint spanner left-span Y))
+ (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
+
+ (left-x (+ padding
+ (max
+ (interval-end (ly:grob-robust-relative-extent
+ left-span common X))
+ (if
+ (and dots
+ (close
+ (ly:grob-relative-coordinate dots common-y Y)
+ (ly:grob-relative-coordinate spanner common-y Y)))
+ (interval-end
+ (ly:grob-robust-relative-extent dots common X))
+ (- INFINITY-INT)))))
+ (right-x (max (- (interval-start
+ (ly:grob-robust-relative-extent right-span common X))
+ padding)
+ (+ left-x minimum-length)))
+ (self-x (ly:grob-relative-coordinate spanner common X))
+ (dx (- right-x left-x))
+ (exp (list 'path thickness
+ `(quote
+ (rmoveto
+ ,(- left-x self-x) 0
+
+ rcurveto
+ ,(/ dx 3)
+ 0
+ ,dx ,(* 0.66 delta-y)
+ ,dx ,delta-y)))))
(ly:make-stencil
exp
(cons (- left-x self-x) (- right-x self-x))
(cons (min 0 delta-y)
- (max 0 delta-y)))))
+ (max 0 delta-y)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (grace-spacing::calc-shortest-duration grob)
(let* ((cols (ly:grob-object grob 'columns))
- (get-difference
- (lambda (idx)
- (ly:moment-sub (ly:grob-property
- (ly:grob-array-ref cols (1+ idx)) 'when)
- (ly:grob-property
- (ly:grob-array-ref cols idx) 'when))))
-
- (moment-min (lambda (x y)
- (cond
- ((and x y)
- (if (ly:moment<? x y)
- x
- y))
- (x x)
- (y y)))))
+ (get-difference
+ (lambda (idx)
+ (ly:moment-sub (ly:grob-property
+ (ly:grob-array-ref cols (1+ idx)) 'when)
+ (ly:grob-property
+ (ly:grob-array-ref cols idx) 'when))))
+
+ (moment-min (lambda (x y)
+ (cond
+ ((and x y)
+ (if (ly:moment<? x y)
+ x
+ y))
+ (x x)
+ (y y)))))
(fold moment-min #f (map get-difference
- (iota (1- (ly:grob-array-length cols)))))))
+ (iota (1- (ly:grob-array-length cols)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (stroke-finger::calc-text grob)
(let ((event (event-cause grob)))
(or (ly:event-property event 'text #f)
- (vector-ref (ly:grob-property grob 'digit-names)
- (1- (max 1
+ (vector-ref (ly:grob-property grob 'digit-names)
+ (1- (max 1
(min 5 (ly:event-property event 'digit))))))))
between the two text elements."
(let ((left-bound (ly:spanner-bound grob LEFT)))
(if (grob::has-interface left-bound 'dynamic-text-interface)
- (let* ((details (ly:grob-property grob 'bound-details))
- (left-details (ly:assoc-get 'left details))
- (my-padding (ly:assoc-get 'padding left-details))
- (script-padding (ly:grob-property left-bound 'right-padding 0)))
-
- (and (number? my-padding)
- (ly:grob-set-nested-property! grob
- '(bound-details left attach-dir)
- RIGHT)
- (ly:grob-set-nested-property! grob
- '(bound-details left padding)
- (+ my-padding script-padding)))))))
+ (let* ((details (ly:grob-property grob 'bound-details))
+ (left-details (ly:assoc-get 'left details))
+ (my-padding (ly:assoc-get 'padding left-details))
+ (script-padding (ly:grob-property left-bound 'right-padding 0)))
+
+ (and (number? my-padding)
+ (ly:grob-set-nested-property! grob
+ '(bound-details left attach-dir)
+ RIGHT)
+ (ly:grob-set-nested-property! grob
+ '(bound-details left padding)
+ (+ my-padding script-padding)))))))
(define-public ((elbowed-hairpin coords mirrored?) grob)
"Create hairpin based on a list of @var{coords} in @code{(cons x y)}
(list (car pair) (cdr pair)))
(define (normalize-coords goods x y)
(map
- (lambda (coord)
- (cons (* x (car coord)) (* y (cdr coord))))
- goods))
+ (lambda (coord)
+ (cons (* x (car coord)) (* y (cdr coord))))
+ goods))
(define (my-c-p-s points thick decresc?)
(make-connected-path-stencil
- points
- thick
- (if decresc? -1.0 1.0)
- 1.0
- #f
- #f))
+ points
+ thick
+ (if decresc? -1.0 1.0)
+ 1.0
+ #f
+ #f))
;; outer let to trigger suicide
(let ((sten (ly:hairpin::print grob)))
(if (grob::is-live? grob)
- (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT))
- (thick (ly:grob-property grob 'thickness 0.1))
- (thick (* thick (layout-line-thickness grob)))
- (xex (ly:stencil-extent sten X))
- (lenx (interval-length xex))
- (yex (ly:stencil-extent sten Y))
- (leny (interval-length yex))
- (xtrans (+ (car xex) (if decresc? lenx 0)))
- (ytrans (car yex))
- (uplist (map pair-to-list
- (normalize-coords coords lenx (/ leny 2))))
- (downlist (map pair-to-list
- (normalize-coords coords lenx (/ leny -2)))))
- (ly:stencil-translate
- (ly:stencil-add
- (my-c-p-s uplist thick decresc?)
- (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
- (cons xtrans ytrans)))
- '())))
+ (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT))
+ (thick (ly:grob-property grob 'thickness 0.1))
+ (thick (* thick (layout-line-thickness grob)))
+ (xex (ly:stencil-extent sten X))
+ (lenx (interval-length xex))
+ (yex (ly:stencil-extent sten Y))
+ (leny (interval-length yex))
+ (xtrans (+ (car xex) (if decresc? lenx 0)))
+ (ytrans (car yex))
+ (uplist (map pair-to-list
+ (normalize-coords coords lenx (/ leny 2))))
+ (downlist (map pair-to-list
+ (normalize-coords coords lenx (/ leny -2)))))
+ (ly:stencil-translate
+ (ly:stencil-add
+ (my-c-p-s uplist thick decresc?)
+ (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
+ (cons xtrans ytrans)))
+ '())))
(define-public flared-hairpin
(elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t))
(let ((text (ly:grob-property grob 'text)))
(grob-interpret-markup grob (if (string? text)
- (make-tied-lyric-markup text)
- text))))
+ (make-tied-lyric-markup text)
+ text))))
(define-public ((grob::calc-property-by-copy prop) grob)
(ly:event-property (event-cause grob) prop))
(define-public slur::height
(ly:make-unpure-pure-container
- ly:slur::height
- ly:slur::pure-height))
+ ly:slur::height
+ ly:slur::pure-height))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; scripts
(define-public (script-interface::calc-x-offset grob)
(ly:grob-property grob 'positioning-done)
(let* ((shift (ly:grob-property grob 'toward-stem-shift 0.0))
- (note-head-location
- (ly:self-alignment-interface::centered-on-x-parent grob))
- (note-head-grob (ly:grob-parent grob X))
- (stem-grob (ly:grob-object note-head-grob 'stem)))
+ (note-head-location
+ (ly:self-alignment-interface::centered-on-x-parent grob))
+ (note-head-grob (ly:grob-parent grob X))
+ (stem-grob (ly:grob-object note-head-grob 'stem)))
(+ note-head-location
;; If the property 'toward-stem-shift is defined and the script
;; Since scripts can also be over skips, we need to check whether
;; the grob has a stem at all.
(if (ly:grob? stem-grob)
- (let ((dir1 (ly:grob-property grob 'direction))
- (dir2 (ly:grob-property stem-grob 'direction)))
- (if (equal? dir1 dir2)
- (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
- (stem-location
- (ly:grob-relative-coordinate stem-grob common-refp X)))
- (* shift (- stem-location note-head-location)))
- 0.0))
- 0.0))))
+ (let ((dir1 (ly:grob-property grob 'direction))
+ (dir2 (ly:grob-property stem-grob 'direction)))
+ (if (equal? dir1 dir2)
+ (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
+ (stem-location
+ (ly:grob-relative-coordinate stem-grob common-refp X)))
+ (* shift (- stem-location note-head-location)))
+ 0.0))
+ 0.0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (system-start-text::print grob)
(let* ((left-bound (ly:spanner-bound grob LEFT))
- (left-mom (ly:grob-property left-bound 'when))
- (name (if (moment<=? left-mom ZERO-MOMENT)
- (ly:grob-property grob 'long-text)
- (ly:grob-property grob 'text))))
+ (left-mom (ly:grob-property left-bound 'when))
+ (name (if (moment<=? left-mom ZERO-MOMENT)
+ (ly:grob-property grob 'long-text)
+ (ly:grob-property grob 'text))))
(if (and (markup? name)
- (!= (ly:item-break-dir left-bound) CENTER))
+ (!= (ly:item-break-dir left-bound) CENTER))
- (grob-interpret-markup grob name)
- (ly:grob-suicide! grob))))
+ (grob-interpret-markup grob name)
+ (ly:grob-suicide! grob))))
(define-public (system-start-text::calc-x-offset grob)
(let* ((left-bound (ly:spanner-bound grob LEFT))
- (left-mom (ly:grob-property left-bound 'when))
- (layout (ly:grob-layout grob))
- (indent (ly:output-def-lookup layout
- (if (moment<=? left-mom ZERO-MOMENT)
- 'indent
- 'short-indent)
- 0.0))
- (system (ly:grob-system grob))
- (my-extent (ly:grob-extent grob system X))
- (elements (ly:grob-object system 'elements))
- (common (ly:grob-common-refpoint-of-array system elements X))
- (total-ext empty-interval)
- (align-x (ly:grob-property grob 'self-alignment-X 0))
- (padding (min 0 (- (interval-length my-extent) indent)))
- (right-padding (- padding
- (/ (* padding (1+ align-x)) 2))))
+ (left-mom (ly:grob-property left-bound 'when))
+ (layout (ly:grob-layout grob))
+ (indent (ly:output-def-lookup layout
+ (if (moment<=? left-mom ZERO-MOMENT)
+ 'indent
+ 'short-indent)
+ 0.0))
+ (system (ly:grob-system grob))
+ (my-extent (ly:grob-extent grob system X))
+ (elements (ly:grob-object system 'elements))
+ (common (ly:grob-common-refpoint-of-array system elements X))
+ (total-ext empty-interval)
+ (align-x (ly:grob-property grob 'self-alignment-X 0))
+ (padding (min 0 (- (interval-length my-extent) indent)))
+ (right-padding (- padding
+ (/ (* padding (1+ align-x)) 2))))
;; compensate for the variation in delimiter extents by
;; calculating an X-offset correction based on united extents
;; of all delimiters in this system
(let unite-delims ((l (ly:grob-array-length elements)))
(if (> l 0)
- (let ((elt (ly:grob-array-ref elements (1- l))))
+ (let ((elt (ly:grob-array-ref elements (1- l))))
- (if (grob::has-interface elt 'system-start-delimiter-interface)
- (let ((dims (ly:grob-extent elt common X)))
- (if (interval-sane? dims)
- (set! total-ext (interval-union total-ext dims)))))
- (unite-delims (1- l)))))
+ (if (grob::has-interface elt 'system-start-delimiter-interface)
+ (let ((dims (ly:grob-extent elt common X)))
+ (if (interval-sane? dims)
+ (set! total-ext (interval-union total-ext dims)))))
+ (unite-delims (1- l)))))
(+
(ly:side-position-interface::x-aligned-side grob)
(ly:grob-array->list elements))))
(let* ((left-bound (ly:spanner-bound grob LEFT))
- (live-elts (live-elements-list grob))
- (system (ly:grob-system grob))
- (extent empty-interval))
+ (live-elts (live-elements-list grob))
+ (system (ly:grob-system grob))
+ (extent empty-interval))
(if (and (pair? live-elts)
- (interval-sane? (ly:grob-extent grob system Y)))
- (let get-extent ((lst live-elts))
- (if (pair? lst)
- (let ((axis-group (car lst)))
-
- (if (and (ly:spanner? axis-group)
- (equal? (ly:spanner-bound axis-group LEFT)
- left-bound))
- (set! extent (add-point extent
- (ly:grob-relative-coordinate
- axis-group system Y))))
- (get-extent (cdr lst)))))
- ;; no live axis group(s) for this instrument name -> remove from system
- (ly:grob-suicide! grob))
+ (interval-sane? (ly:grob-extent grob system Y)))
+ (let get-extent ((lst live-elts))
+ (if (pair? lst)
+ (let ((axis-group (car lst)))
+
+ (if (and (ly:spanner? axis-group)
+ (equal? (ly:spanner-bound axis-group LEFT)
+ left-bound))
+ (set! extent (add-point extent
+ (ly:grob-relative-coordinate
+ axis-group system Y))))
+ (get-extent (cdr lst)))))
+ ;; no live axis group(s) for this instrument name -> remove from system
+ (ly:grob-suicide! grob))
(+
(ly:self-alignment-interface::y-aligned-on-self grob)
(define-public axis-group-interface::height
(ly:make-unpure-pure-container
- ly:axis-group-interface::height
- ly:axis-group-interface::pure-height))
+ ly:axis-group-interface::height
+ ly:axis-group-interface::pure-height))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ambitus
(let ((heads (ly:grob-object grob 'note-heads)))
(if (and (ly:grob-array? heads)
- (= (ly:grob-array-length heads) 2))
- (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
- (head-down (ly:grob-array-ref heads 0))
- (head-up (ly:grob-array-ref heads 1))
- (gap (ly:grob-property grob 'gap 0.35))
- (point-min (+ (interval-end (ly:grob-extent head-down common Y))
- gap))
- (point-max (- (interval-start (ly:grob-extent head-up common Y))
- gap)))
-
- (if (< point-min point-max)
- (let* ((layout (ly:grob-layout grob))
- (line-thick (ly:output-def-lookup layout 'line-thickness))
- (blot (ly:output-def-lookup layout 'blot-diameter))
- (grob-thick (ly:grob-property grob 'thickness 2))
- (width (* line-thick grob-thick))
- (x-ext (symmetric-interval (/ width 2)))
- (y-ext (cons point-min point-max))
- (line (ly:round-filled-box x-ext y-ext blot))
- (y-coord (ly:grob-relative-coordinate grob common Y)))
-
- (ly:stencil-translate-axis line (- y-coord) Y))
- empty-stencil))
- (begin
- (ly:grob-suicide! grob)
- (list)))))
+ (= (ly:grob-array-length heads) 2))
+ (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
+ (head-down (ly:grob-array-ref heads 0))
+ (head-up (ly:grob-array-ref heads 1))
+ (gap (ly:grob-property grob 'gap 0.35))
+ (point-min (+ (interval-end (ly:grob-extent head-down common Y))
+ gap))
+ (point-max (- (interval-start (ly:grob-extent head-up common Y))
+ gap)))
+
+ (if (< point-min point-max)
+ (let* ((layout (ly:grob-layout grob))
+ (line-thick (ly:output-def-lookup layout 'line-thickness))
+ (blot (ly:output-def-lookup layout 'blot-diameter))
+ (grob-thick (ly:grob-property grob 'thickness 2))
+ (width (* line-thick grob-thick))
+ (x-ext (symmetric-interval (/ width 2)))
+ (y-ext (cons point-min point-max))
+ (line (ly:round-filled-box x-ext y-ext blot))
+ (y-coord (ly:grob-relative-coordinate grob common Y)))
+
+ (ly:stencil-translate-axis line (- y-coord) Y))
+ empty-stencil))
+ (begin
+ (ly:grob-suicide! grob)
+ (list)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; laissez-vibrer tie
;; needed so we can make laissez-vibrer a pure print
;;
(define-public (laissez-vibrer::print grob)
- (ly:tie::print grob))
+ (ly:tie::print grob))
(define-public (semi-tie::calc-cross-staff grob)
(let* ((note-head (ly:grob-object grob 'note-head))
(define-public (volta-bracket-interface::pure-height grob start end)
(let ((edge-height (ly:grob-property grob 'edge-height)))
(if (number-pair? edge-height)
- (let ((smaller (min (car edge-height) (cdr edge-height)))
- (larger (max (car edge-height) (cdr edge-height))))
- (interval-union '(0 . 0) (cons smaller larger)))
- '(0 . 0))))
+ (let ((smaller (min (car edge-height) (cdr edge-height)))
+ (larger (max (car edge-height) (cdr edge-height))))
+ (interval-union '(0 . 0) (cons smaller larger)))
+ '(0 . 0))))
#:re-export (quote))
(use-modules (guile)
- (ice-9 regex)
- (ice-9 optargs)
- (srfi srfi-1)
- (srfi srfi-13)
- (scm framework-ps)
- (lily))
+ (ice-9 regex)
+ (ice-9 optargs)
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (scm framework-ps)
+ (lily))
;;; helper functions, not part of output interface
;;;
(define (str4 num)
(if (or (nan? num) (inf? num))
(begin
- (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
- (if (ly:get-option 'strict-infinity-checking)
- (exit 1))
- "0.0")
+ (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
+ (if (ly:get-option 'strict-infinity-checking)
+ (exit 1))
+ "0.0")
(ly:number->string num)))
(define (number-pair->string4 numpair)
(define (char font i)
(ly:format "~a (\\~a) show"
- (ps-font-command font)
- (ly:inexact->string i 8)))
+ (ps-font-command font)
+ (ly:inexact->string i 8)))
(define (circle radius thick fill)
(ly:format
"~a ~4f ~4f draw_circle"
(if fill
- "true"
- "false")
+ "true"
+ "false")
radius thick))
(define (start-enclosing-id-node s)
(define (dashed-line thick on off dx dy phase)
(ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
- dx
- dy
- thick
- on
- off
- phase))
+ dx
+ dy
+ thick
+ on
+ off
+ phase))
(define (draw-line thick x1 y1 x2 y2)
(ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
- (- x2 x1) (- y2 y1)
- x1 y1 thick))
+ (- x2 x1) (- y2 y1)
+ x1 y1 thick))
(define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
(ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse"
- (if fill "true" "false")
- (if connect "true" "false")
- x-radius
- y-radius
- start-angle
- end-angle
- thick))
+ (if fill "true" "false")
+ (if connect "true" "false")
+ x-radius
+ y-radius
+ start-angle
+ end-angle
+ thick))
(define (ellipse x-radius y-radius thick fill)
(ly:format
"~a ~4f ~4f ~4f draw_ellipse"
(if fill
- "true"
- "false")
+ "true"
+ "false")
x-radius y-radius thick))
(define (embedded-ps string)
(define (glyph-string pango-font
postscript-font-name
- size
- cid?
- w-x-y-named-glyphs)
+ size
+ cid?
+ w-x-y-named-glyphs)
(define (glyph-spec w h x y g) ; h not used
(let ((prefix (if (string? g) "/" "")))
(ly:format "~4f ~4f ~4f ~a~a"
- w x y
- prefix g)))
+ w x y
+ prefix g)))
(ly:format
(if cid?
-"/~a /CIDFont findresource ~a output-scale div scalefont setfont
+ "/~a /CIDFont findresource ~a output-scale div scalefont setfont
~a
~a print_glyphs"
-"/~a ~a output-scale div selectfont
+ "/~a ~a output-scale div selectfont
~a
~a print_glyphs")
- postscript-font-name
- size
- (string-join (map (lambda (x) (apply glyph-spec x))
- (reverse w-x-y-named-glyphs)) "\n")
- (length w-x-y-named-glyphs)))
+ postscript-font-name
+ size
+ (string-join (map (lambda (x) (apply glyph-spec x))
+ (reverse w-x-y-named-glyphs)) "\n")
+ (length w-x-y-named-glyphs)))
(define (grob-cause offset grob)
(if (ly:get-option 'point-and-click)
(let* ((cause (ly:grob-property grob 'cause))
- (music-origin (if (ly:stream-event? cause)
- (ly:event-property cause 'origin)))
- (point-and-click (ly:get-option 'point-and-click)))
- (if (and
- (ly:input-location? music-origin)
- (cond ((boolean? point-and-click) point-and-click)
- ((symbol? point-and-click)
- (ly:in-event-class? cause point-and-click))
- (else (any (lambda (t)
- (ly:in-event-class? cause t))
- point-and-click))))
- (let* ((location (ly:input-file-line-char-column music-origin))
- (raw-file (car location))
- (file (if (is-absolute? raw-file)
- raw-file
- (string-append (ly-getcwd) "/" raw-file)))
- (x-ext (ly:grob-extent grob grob X))
- (y-ext (ly:grob-extent grob grob Y)))
-
- (if (and (< 0 (interval-length x-ext))
- (< 0 (interval-length y-ext)))
- (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
- (+ (car offset) (car x-ext))
- (+ (cdr offset) (car y-ext))
- (+ (car offset) (cdr x-ext))
- (+ (cdr offset) (cdr y-ext))
-
- ;; Backslashes are not valid
- ;; file URI path separators.
- (ly:string-percent-encode
- (ly:string-substitute "\\" "/" file))
-
- (cadr location)
- (caddr location)
- (1+ (cadddr location)))
- ""))
- ""))
+ (music-origin (if (ly:stream-event? cause)
+ (ly:event-property cause 'origin)))
+ (point-and-click (ly:get-option 'point-and-click)))
+ (if (and
+ (ly:input-location? music-origin)
+ (cond ((boolean? point-and-click) point-and-click)
+ ((symbol? point-and-click)
+ (ly:in-event-class? cause point-and-click))
+ (else (any (lambda (t)
+ (ly:in-event-class? cause t))
+ point-and-click))))
+ (let* ((location (ly:input-file-line-char-column music-origin))
+ (raw-file (car location))
+ (file (if (is-absolute? raw-file)
+ raw-file
+ (string-append (ly-getcwd) "/" raw-file)))
+ (x-ext (ly:grob-extent grob grob X))
+ (y-ext (ly:grob-extent grob grob Y)))
+
+ (if (and (< 0 (interval-length x-ext))
+ (< 0 (interval-length y-ext)))
+ (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
+ (+ (car offset) (car x-ext))
+ (+ (cdr offset) (car y-ext))
+ (+ (car offset) (cdr x-ext))
+ (+ (cdr offset) (cdr y-ext))
+
+ ;; Backslashes are not valid
+ ;; file URI path separators.
+ (ly:string-percent-encode
+ (ly:string-substitute "\\" "/" file))
+
+ (cadr location)
+ (caddr location)
+ (1+ (cadddr location)))
+ ""))
+ ""))
""))
(define (named-glyph font glyph)
(ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
- (ps-font-command font)
- glyph))
+ (ps-font-command font)
+ glyph))
(define (no-origin)
"")
(define (polygon points blot-diameter filled?)
(ly:format "~a ~4l ~a ~4f draw_polygon"
- (if filled? "true" "false")
- points
- (- (/ (length points) 2) 1)
- blot-diameter))
+ (if filled? "true" "false")
+ points
+ (- (/ (length points) 2) 1)
+ blot-diameter))
(define (round-filled-box left right bottom top blotdiam)
(let* ((halfblot (/ blotdiam 2))
- (x (- halfblot left))
- (width (- right (+ halfblot x)))
- (y (- halfblot bottom))
- (height (- top (+ halfblot y))))
+ (x (- halfblot left))
+ (width (- right (+ halfblot x)))
+ (y (- halfblot bottom))
+ (height (- top (+ halfblot y))))
(ly:format "~4l draw_round_box"
- (list width height x y blotdiam))))
+ (list width height x y blotdiam))))
;; save current color on stack and set new color
(define (setcolor r g b)
(ly:format "gsave ~4l setrgbcolor\n"
- (list r g b)))
+ (list r g b)))
;; restore color from stack
(define (resetcolor) "grestore\n")
;; rotation around given point
(define (setrotation ang x y)
(ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
- (list x y)
- ang
- (list (* -1 x) (* -1 y))))
+ (list x y)
+ ang
+ (list (* -1 x) (* -1 y))))
(define (resetrotation ang x y)
"grestore ")
(define (url-link url x y)
(ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add (~a) mark_URI"
- (car x)
- (car y)
- (cdr x)
- (cdr y)
- url))
+ (car x)
+ (car y)
+ (cdr x)
+ (cdr y)
+ url))
(define (page-link page-no x y)
(if (number? page-no)
- (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add ~a mark_page_link"
- (car x)
- (car y)
- (cdr x)
- (cdr y)
- page-no)
- ""))
+ (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add ~a mark_page_link"
+ (car x)
+ (car y)
+ (cdr x)
+ (cdr y)
+ page-no)
+ ""))
(define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
(define (convert-path-exps exps)
(if (pair? exps)
- (let*
- ((head (car exps))
- (rest (cdr exps))
- (arity
- (cond
- ((memq head '(rmoveto rlineto lineto moveto)) 2)
- ((memq head '(rcurveto curveto)) 6)
- ((eq? head 'closepath) 0)
- (else 1)))
- (args (take rest arity))
- )
-
- ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
- (cons (ly:format
- "~l ~a "
- args
- head)
- (convert-path-exps (drop rest arity))))
- '()))
+ (let*
+ ((head (car exps))
+ (rest (cdr exps))
+ (arity
+ (cond
+ ((memq head '(rmoveto rlineto lineto moveto)) 2)
+ ((memq head '(rcurveto curveto)) 6)
+ ((eq? head 'closepath) 0)
+ (else 1)))
+ (args (take rest arity))
+ )
+
+ ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
+ (cons (ly:format
+ "~l ~a "
+ args
+ head)
+ (convert-path-exps (drop rest arity))))
+ '()))
(let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
- (else (begin
- (ly:warning (_ "unknown line-cap-style: ~S")
- (symbol->string cap))
- 1))))
- (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
- (else (begin
- (ly:warning (_ "unknown line-join-style: ~S")
- (symbol->string join))
- 1)))))
+ (else (begin
+ (ly:warning (_ "unknown line-cap-style: ~S")
+ (symbol->string cap))
+ 1))))
+ (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
+ (else (begin
+ (ly:warning (_ "unknown line-join-style: ~S")
+ (symbol->string join))
+ 1)))))
(ly:format
"gsave currentpoint translate
~a setlinecap ~a setlinejoin ~a setlinewidth
(define (setscale x y)
(ly:format "gsave ~4l scale\n"
- (list x y)))
+ (list x y)))
(define (resetscale)
"grestore\n")
#:re-export (quote))
(use-modules (guile)
- (srfi srfi-1)
- (srfi srfi-13)
- (lily))
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (lily))
(define format ergonomic-simple-format)
(define (event-cause grob)
(let*
- ((cause (ly:grob-property grob 'cause)))
+ ((cause (ly:grob-property grob 'cause)))
(if (ly:stream-event? cause)
- cause
- #f)))
+ cause
+ #f)))
(define (grob-bbox grob offset)
(let*
- ((x-ext (ly:grob-extent grob grob X))
- (y-ext (ly:grob-extent grob grob Y))
- (x (car offset))
- (y (cdr offset)))
+ ((x-ext (ly:grob-extent grob grob X))
+ (y-ext (ly:grob-extent grob grob Y))
+ (x (car offset))
+ (y (cdr offset)))
(if (interval-empty? x-ext)
- (set! x-ext '(0 . 0)))
+ (set! x-ext '(0 . 0)))
(if (interval-empty? y-ext)
- (set! y-ext '(0 . 0)))
+ (set! y-ext '(0 . 0)))
(list (+ x (car x-ext))
- (+ y (car y-ext))
- (+ x (cdr x-ext))
- (+ y (cdr y-ext)))))
+ (+ y (car y-ext))
+ (+ x (cdr x-ext))
+ (+ y (cdr y-ext)))))
(define (escape-string str)
(string-regexp-substitute
- " " "\\040"
- (string-regexp-substitute "\"" "\\\"" str)))
+ " " "\\040"
+ (string-regexp-substitute "\"" "\\\"" str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; stencil commands
(define (draw-line thick x1 y1 x2 y2)
(format #f "drawline ~a ~a ~a ~a ~a"
- thick x1 y2 x2 y2))
+ thick x1 y2 x2 y2))
(define (grob-cause offset grob)
(let*
- ((cause (event-cause grob))
- (tag (if (and cause (integer? (ly:event-property cause 'input-tag)))
- (ly:event-property cause 'input-tag)
- -1))
- (name (assoc-get 'name (ly:grob-property grob 'meta))))
+ ((cause (event-cause grob))
+ (tag (if (and cause (integer? (ly:event-property cause 'input-tag)))
+ (ly:event-property cause 'input-tag)
+ -1))
+ (name (assoc-get 'name (ly:grob-property grob 'meta))))
(apply format #f
- "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name
- (grob-bbox grob offset))))
+ "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name
+ (grob-bbox grob offset))))
(define (named-glyph font glyph)
(format #f "glyphshow ~a \"~a\" ~a \"~a\""
- (ly:font-glyph-name-to-charcode font glyph)
- (ly:font-name font)
- (modified-font-metric-font-scaling font)
- glyph))
+ (ly:font-glyph-name-to-charcode font glyph)
+ (ly:font-name font)
+ (modified-font-metric-font-scaling font)
+ glyph))
(define (no-origin)
"nocause\n")
(define (polygon xy-coords blot do-fill)
(format #f "polygon ~a ~a ~a"
- blot
- (if do-fill "True" "False")
- (string-join (map number->string xy-coords))))
+ blot
+ (if do-fill "True" "False")
+ (string-join (map number->string xy-coords))))
(define (round-filled-box breapth width depth height blot-diameter)
(format #f "draw_round_box ~a ~a ~a ~a ~a"
- breapth width depth height blot-diameter))
+ breapth width depth height blot-diameter))
(define (utf-8-string descr string)
(format #f "utf-8 \"~a\" \"~a\""
- (escape-string descr)
- ;; don't want unescaped spaces.
- (escape-string string)))
+ (escape-string descr)
+ ;; don't want unescaped spaces.
+ (escape-string string)))
;;; set by framework-gnome.scm
(define paper #f)
-
+
(use-modules
- (guile)
- (ice-9 regex)
- (ice-9 format)
- (ice-9 optargs)
- (lily)
- (srfi srfi-1)
- (srfi srfi-13))
+ (guile)
+ (ice-9 regex)
+ (ice-9 format)
+ (ice-9 optargs)
+ (lily)
+ (srfi srfi-1)
+ (srfi srfi-13))
(define fancy-format format)
(define format ergonomic-simple-format)
;; Helper functions
(define-public (attributes attributes-alist)
(apply string-append
- (map (lambda (x)
- (let ((attr (car x))
- (value (cdr x)))
- (if (number? value)
- (set! value (ly:format "~4f" value)))
- (format #f " ~s=\"~a\"" attr value)))
- attributes-alist)))
+ (map (lambda (x)
+ (let ((attr (car x))
+ (value (cdr x)))
+ (if (number? value)
+ (set! value (ly:format "~4f" value)))
+ (format #f " ~s=\"~a\"" attr value)))
+ attributes-alist)))
(define-public (eo entity . attributes-alist)
"o = open"
(if (equal? string "")
(apply eoc entity attributes-alist)
(string-append
- (apply eo (cons entity attributes-alist)) string (ec entity))))
+ (apply eo (cons entity attributes-alist)) string (ec entity))))
(define (offset->point o)
(ly:format "~4f ~4f" (car o) (- (cdr o))))
(define (number-list->point lst)
(define (helper lst)
(if (null? lst)
- '()
- (cons (format #f "~S ~S" (car lst) (- (cadr lst)))
- (helper (cddr lst)))))
+ '()
+ (cons (format #f "~S ~S" (car lst) (- (cadr lst)))
+ (helper (cddr lst)))))
(string-join (helper lst) " "))
(define (svg-bezier lst close)
(let* ((c0 (car (list-tail lst 3)))
- (c123 (list-head lst 3)))
+ (c123 (list-head lst 3)))
(string-append
- (if (not close) "M" "L")
- (offset->point c0)
- "C" (string-join (map offset->point c123) " ")
- (if (not close) "" "z"))))
+ (if (not close) "M" "L")
+ (offset->point c0)
+ "C" (string-join (map offset->point c123) " ")
+ (if (not close) "" "z"))))
(define (sqr x)
(* x x))
(define (string->entities string)
(apply string-append
- (map (lambda (x) (char->entity x)) (string->list string))))
+ (map (lambda (x) (char->entity x)) (string->list string))))
(define svg-element-regexp
(make-regexp "^(<[a-z]+) ?(.*>)"))
(define (set-attribute attr val)
(set! alist (assoc-set! alist attr val)))
(let* ((match-1 (regexp-exec pango-description-regexp-comma str))
- (match-2 (regexp-exec pango-description-regexp-nocomma str))
- (match (if match-1 match-1 match-2)))
+ (match-2 (regexp-exec pango-description-regexp-nocomma str))
+ (match (if match-1 match-1 match-2)))
(if (regexp-match? match)
- (begin
- (set-attribute 'font-family (match:prefix match))
- (if (string? (match:substring match 1))
- (set-attribute 'font-weight "bold"))
- (if (string? (match:substring match 2))
- (set-attribute 'font-style "italic"))
- (if (string? (match:substring match 3))
- (set-attribute 'font-variant "small-caps"))
- (set-attribute 'font-size
- (/ (string->number (match:substring match 4))
- lily-unit-length))
- (set-attribute 'text-anchor "start")
- (set-attribute 'fill "currentColor"))
- (ly:warning (_ "cannot decypher Pango description: ~a") str))
+ (begin
+ (set-attribute 'font-family (match:prefix match))
+ (if (string? (match:substring match 1))
+ (set-attribute 'font-weight "bold"))
+ (if (string? (match:substring match 2))
+ (set-attribute 'font-style "italic"))
+ (if (string? (match:substring match 3))
+ (set-attribute 'font-variant "small-caps"))
+ (set-attribute 'font-size
+ (/ (string->number (match:substring match 4))
+ lily-unit-length))
+ (set-attribute 'text-anchor "start")
+ (set-attribute 'fill "currentColor"))
+ (ly:warning (_ "cannot decypher Pango description: ~a") str))
(apply entity 'text expr (reverse! alist))))
(set! alist (assoc-set! alist attr val)))
(if (not (null? rest))
(let* ((dx (car rest))
- (dy (cadr rest))
- (total-x (+ dx next-horiz-adv)))
- (if (or (not (zero? total-x))
- (not (zero? dy)))
- (let ((x (ly:format "~4f" total-x))
- (y (ly:format "~4f" dy)))
- (set-attribute 'transform
- (string-append
- "translate(" x ", " y ") "
- "scale(" scale ", -" scale ")")))
- (set-attribute 'transform
- (string-append
- "scale(" scale ", -" scale ")"))))
+ (dy (cadr rest))
+ (total-x (+ dx next-horiz-adv)))
+ (if (or (not (zero? total-x))
+ (not (zero? dy)))
+ (let ((x (ly:format "~4f" total-x))
+ (y (ly:format "~4f" dy)))
+ (set-attribute 'transform
+ (string-append
+ "translate(" x ", " y ") "
+ "scale(" scale ", -" scale ")")))
+ (set-attribute 'transform
+ (string-append
+ "scale(" scale ", -" scale ")"))))
(set-attribute 'transform (string-append
- "scale(" scale ", -" scale ")")))
+ "scale(" scale ", -" scale ")")))
(set-attribute 'd path)
(set-attribute 'fill "currentColor")
;;
(define (glyph-element-regexp name)
(make-regexp (string-append "<glyph"
- "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
- "[[:space:]]+glyph-name=\"("
- name
- ")\""
- "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
- "([[:space:]]+)?"
- "/>")))
+ "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
+ "[[:space:]]+glyph-name=\"("
+ name
+ ")\""
+ "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
+ "([[:space:]]+)?"
+ "/>")))
(define (extract-glyph all-glyphs name size . rest)
(let* ((new-name (regexp-quote name))
- (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
- (glyph (match:substring regexp))
- (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
- (unicode-attr-value (match:substring unicode-attr 1))
- (unicode-attr? (regexp-match? unicode-attr))
- (d-attr (regexp-exec glyph-path-regexp glyph))
- (d-attr-value "")
- (d-attr? (regexp-match? d-attr))
- ;; TODO: not urgent, but do not hardcode this value
- (units-per-em 1000)
- (font-scale (ly:format "~4f" (/ size units-per-em)))
- (path ""))
+ (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
+ (glyph (match:substring regexp))
+ (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
+ (unicode-attr-value (match:substring unicode-attr 1))
+ (unicode-attr? (regexp-match? unicode-attr))
+ (d-attr (regexp-exec glyph-path-regexp glyph))
+ (d-attr-value "")
+ (d-attr? (regexp-match? d-attr))
+ ;; TODO: not urgent, but do not hardcode this value
+ (units-per-em 1000)
+ (font-scale (ly:format "~4f" (/ size units-per-em)))
+ (path ""))
(if (and unicode-attr? (not unicode-attr-value))
- (ly:warning (_ "Glyph must have a unicode value")))
+ (ly:warning (_ "Glyph must have a unicode value")))
(if d-attr? (set! d-attr-value (match:substring d-attr 1)))
(cond (
- ;; Glyph-strings with path data
- (and d-attr? (not (null? rest)))
- (begin
- (set! path (apply dump-path d-attr-value
- font-scale
- (list (caddr rest) (cadddr rest))))
- (set! next-horiz-adv (+ next-horiz-adv
- (car rest)))
- path))
- ;; Glyph-strings without path data ("space")
- ((and (not d-attr?) (not (null? rest)))
- (begin
- (set! next-horiz-adv (+ next-horiz-adv
- (car rest)))
- ""))
- ;; Font smobs with path data
- ((and d-attr? (null? rest))
- (set! path (dump-path d-attr-value font-scale))
- path)
- ;; Font smobs without path data ("space")
- (else
- ""))))
+ ;; Glyph-strings with path data
+ (and d-attr? (not (null? rest)))
+ (begin
+ (set! path (apply dump-path d-attr-value
+ font-scale
+ (list (caddr rest) (cadddr rest))))
+ (set! next-horiz-adv (+ next-horiz-adv
+ (car rest)))
+ path))
+ ;; Glyph-strings without path data ("space")
+ ((and (not d-attr?) (not (null? rest)))
+ (begin
+ (set! next-horiz-adv (+ next-horiz-adv
+ (car rest)))
+ ""))
+ ;; Font smobs with path data
+ ((and d-attr? (null? rest))
+ (set! path (dump-path d-attr-value font-scale))
+ path)
+ ;; Font smobs without path data ("space")
+ (else
+ ""))))
(define (extract-glyph-info all-glyphs glyph size)
(let* ((offsets (list-head glyph 4))
- (glyph-name (car (reverse glyph))))
+ (glyph-name (car (reverse glyph))))
(apply extract-glyph all-glyphs glyph-name size offsets)))
(define (svg-defs svg-font)
(let ((start (string-contains svg-font "<defs>"))
- (end (string-contains svg-font "</defs>")))
+ (end (string-contains svg-font "</defs>")))
(substring svg-font (+ start 7) (- end 1))))
(define (cache-font svg-font size glyph)
(let ((all-glyphs (svg-defs (cached-file-contents svg-font))))
(if (list? glyph)
- (extract-glyph-info all-glyphs glyph size)
- (extract-glyph all-glyphs glyph size))))
+ (extract-glyph-info all-glyphs glyph size)
+ (extract-glyph all-glyphs glyph size))))
(define (music-string-to-path font size glyph)
(let* ((name-style (font-name-style font))
- (scaled-size (/ size lily-unit-length))
- (font-file (ly:find-file (string-append name-style ".svg"))))
+ (scaled-size (/ size lily-unit-length))
+ (font-file (ly:find-file (string-append name-style ".svg"))))
(if font-file
- (cache-font font-file scaled-size glyph)
- (ly:warning (_ "cannot find SVG font ~S") font-file))))
+ (cache-font font-file scaled-size glyph)
+ (ly:warning (_ "cannot find SVG font ~S") font-file))))
(define (font-smob-to-path font glyph)
(let* ((name-style (font-name-style font))
- (scaled-size (modified-font-metric-font-scaling font))
- (font-file (ly:find-file (string-append name-style ".svg"))))
+ (scaled-size (modified-font-metric-font-scaling font))
+ (font-file (ly:find-file (string-append name-style ".svg"))))
(if font-file
- (cache-font font-file scaled-size glyph)
- (ly:warning (_ "cannot find SVG font ~S") font-file))))
+ (cache-font font-file scaled-size glyph)
+ (ly:warning (_ "cannot find SVG font ~S") font-file))))
(define (woff-font-smob-to-text font expr)
(let* ((name-style (font-name-style font))
- (scaled-size (modified-font-metric-font-scaling font))
- (font-file (ly:find-file (string-append name-style ".woff")))
- (charcode (ly:font-glyph-name-to-charcode font expr))
- (char-lookup (format #f "&#~S;" charcode))
- (glyph-by-name (eoc 'altglyph `(glyphname . ,expr)))
- (apparently-broken
- (comment "FIXME: how to select glyph by name, altglyph is broken?"))
- (text (string-regexp-substitute "\n" ""
- (string-append glyph-by-name apparently-broken char-lookup))))
- (define alist '())
- (define (set-attribute attr val)
- (set! alist (assoc-set! alist attr val)))
- (set-attribute 'font-family name-style)
- (set-attribute 'font-size scaled-size)
- (apply entity 'text text (reverse! alist))))
-
+ (scaled-size (modified-font-metric-font-scaling font))
+ (font-file (ly:find-file (string-append name-style ".woff")))
+ (charcode (ly:font-glyph-name-to-charcode font expr))
+ (char-lookup (format #f "&#~S;" charcode))
+ (glyph-by-name (eoc 'altglyph `(glyphname . ,expr)))
+ (apparently-broken
+ (comment "FIXME: how to select glyph by name, altglyph is broken?"))
+ (text (string-regexp-substitute "\n" ""
+ (string-append glyph-by-name apparently-broken char-lookup))))
+ (define alist '())
+ (define (set-attribute attr val)
+ (set! alist (assoc-set! alist attr val)))
+ (set-attribute 'font-family name-style)
+ (set-attribute 'font-size scaled-size)
+ (apply entity 'text text (reverse! alist))))
+
(define font-smob-to-text
(if (not (ly:get-option 'svg-woff))
font-smob-to-path woff-font-smob-to-text))
(define (circle radius thick is-filled)
(entity
- 'circle ""
- '(stroke-linejoin . "round")
- '(stroke-linecap . "round")
- `(fill . ,(if is-filled "currentColor" "none"))
- `(stroke . "currentColor")
- `(stroke-width . ,thick)
- `(r . ,radius)))
+ 'circle ""
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(fill . ,(if is-filled "currentColor" "none"))
+ `(stroke . "currentColor")
+ `(stroke-width . ,thick)
+ `(r . ,radius)))
(define (dashed-line thick on off dx dy phase)
(draw-line thick 0 0 dx dy
- `(stroke-dasharray . ,(format #f "~a,~a" on off))))
+ `(stroke-dasharray . ,(format #f "~a,~a" on off))))
(define (draw-line thick x1 y1 x2 y2 . alist)
(apply entity 'line ""
- (append
- `((stroke-linejoin . "round")
- (stroke-linecap . "round")
- (stroke-width . ,thick)
- (stroke . "currentColor")
- (x1 . ,x1)
- (y1 . ,(- y1))
- (x2 . ,x2)
- (y2 . ,(- y2)))
- alist)))
+ (append
+ `((stroke-linejoin . "round")
+ (stroke-linecap . "round")
+ (stroke-width . ,thick)
+ (stroke . "currentColor")
+ (x1 . ,x1)
+ (y1 . ,(- y1))
+ (x2 . ,x2)
+ (y2 . ,(- y2)))
+ alist)))
(define (ellipse x-radius y-radius thick is-filled)
(entity
- 'ellipse ""
- '(stroke-linejoin . "round")
- '(stroke-linecap . "round")
- `(fill . ,(if is-filled "currentColor" "none"))
- `(stroke . "currentColor")
- `(stroke-width . ,thick)
- `(rx . ,x-radius)
- `(ry . ,y-radius)))
+ 'ellipse ""
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(fill . ,(if is-filled "currentColor" "none"))
+ `(stroke . "currentColor")
+ `(stroke-width . ,thick)
+ `(rx . ,x-radius)
+ `(ry . ,y-radius)))
(define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
(define (make-ellipse-radius x-radius y-radius angle)
(* (* x-radius x-radius)
(* (sin angle) (sin angle)))))))
(let*
- ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle)))
- (start-radius (make-ellipse-radius x-radius y-radius new-start-angle))
- (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle)))
- (end-radius (make-ellipse-radius x-radius y-radius new-end-angle))
- (epsilon 1.5e-3)
- (x-end (- (* end-radius (cos new-end-angle))
- (* start-radius (cos new-start-angle))))
- (y-end (- (* end-radius (sin new-end-angle))
- (* start-radius (sin new-start-angle)))))
- (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
- (entity
- 'ellipse ""
- `(fill . ,(if fill "currentColor" "none"))
- `(stroke . "currentColor")
- `(stroke-width . ,thick)
- '(stroke-linejoin . "round")
- '(stroke-linecap . "round")
- '(cx . 0)
- '(cy . 0)
- `(rx . ,x-radius)
- `(ry . ,y-radius))
- (entity
- 'path ""
- `(fill . ,(if fill "currentColor" "none"))
- `(stroke . "currentColor")
- `(stroke-width . ,thick)
- '(stroke-linejoin . "round")
- '(stroke-linecap . "round")
- (cons
- 'd
- (string-append
- (ly:format
+ ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle)))
+ (start-radius (make-ellipse-radius x-radius y-radius new-start-angle))
+ (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle)))
+ (end-radius (make-ellipse-radius x-radius y-radius new-end-angle))
+ (epsilon 1.5e-3)
+ (x-end (- (* end-radius (cos new-end-angle))
+ (* start-radius (cos new-start-angle))))
+ (y-end (- (* end-radius (sin new-end-angle))
+ (* start-radius (sin new-start-angle)))))
+ (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
+ (entity
+ 'ellipse ""
+ `(fill . ,(if fill "currentColor" "none"))
+ `(stroke . "currentColor")
+ `(stroke-width . ,thick)
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ '(cx . 0)
+ '(cy . 0)
+ `(rx . ,x-radius)
+ `(ry . ,y-radius))
+ (entity
+ 'path ""
+ `(fill . ,(if fill "currentColor" "none"))
+ `(stroke . "currentColor")
+ `(stroke-width . ,thick)
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ (cons
+ 'd
+ (string-append
+ (ly:format
"M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f"
(* start-radius (cos new-start-angle))
(- (* start-radius (sin new-start-angle)))
(if (> 0 (- new-start-angle new-end-angle)) 0 1)
(* end-radius (cos new-end-angle))
(- (* end-radius (sin new-end-angle))))
- (if connect
- (ly:format "L~4f,~4f"
- (* start-radius (cos new-start-angle))
- (- (* start-radius (sin new-start-angle))))
- "")))))))
+ (if connect
+ (ly:format "L~4f,~4f"
+ (* start-radius (cos new-start-angle))
+ (- (* start-radius (sin new-start-angle))))
+ "")))))))
(define (embedded-svg string)
string)
(if (= 1 (length glyphs))
(set! path (music-string-to-path font size (car glyphs)))
(begin
- (set! path
- (string-append (eo 'g)
- (string-join
- (map (lambda (x)
- (music-string-to-path font size x))
- glyphs)
- "\n")
- (ec 'g)))))
+ (set! path
+ (string-append (eo 'g)
+ (string-join
+ (map (lambda (x)
+ (music-string-to-path font size x))
+ glyphs)
+ "\n")
+ (ec 'g)))))
(set! next-horiz-adv 0.0)
path)
(define (woff-glyph-string pango-font font-name size cid? w-h-x-y-named-glyphs)
(let* ((name-style (font-name-style font-name))
- (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)")
- font-name))
- (family (if (regexp-match? family-designsize)
- (match:substring family-designsize 1)
- font-name))
- (design-size (if (regexp-match? family-designsize)
- (match:substring family-designsize 2)
- #f))
- (scaled-size (/ size lily-unit-length))
- (font (ly:paper-get-font paper `(((font-family . ,family)
- ,(if design-size
- `(design-size . design-size)))))))
+ (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)")
+ font-name))
+ (family (if (regexp-match? family-designsize)
+ (match:substring family-designsize 1)
+ font-name))
+ (design-size (if (regexp-match? family-designsize)
+ (match:substring family-designsize 2)
+ #f))
+ (scaled-size (/ size lily-unit-length))
+ (font (ly:paper-get-font paper `(((font-family . ,family)
+ ,(if design-size
+ `(design-size . design-size)))))))
(define (glyph-spec w h x y g) ; h not used
(let* ((charcode (ly:font-glyph-name-to-charcode font g))
- (char-lookup (format #f "&#~S;" charcode))
- (glyph-by-name (eoc 'altglyph `(glyphname . ,g)))
- (apparently-broken
- (comment "XFIXME: how to select glyph by name, altglyph is broken?")))
- ;; what is W?
- (ly:format
- "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>"
- (if (or (> (abs x) 0.00001)
- (> (abs y) 0.00001))
- (ly:format " transform=\"translate(~4f,~4f)\"" x y)
- " ")
- name-style scaled-size
- (string-regexp-substitute
- "\n" ""
- (string-append glyph-by-name apparently-broken char-lookup)))))
+ (char-lookup (format #f "&#~S;" charcode))
+ (glyph-by-name (eoc 'altglyph `(glyphname . ,g)))
+ (apparently-broken
+ (comment "XFIXME: how to select glyph by name, altglyph is broken?")))
+ ;; what is W?
+ (ly:format
+ "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>"
+ (if (or (> (abs x) 0.00001)
+ (> (abs y) 0.00001))
+ (ly:format " transform=\"translate(~4f,~4f)\"" x y)
+ " ")
+ name-style scaled-size
+ (string-regexp-substitute
+ "\n" ""
+ (string-append glyph-by-name apparently-broken char-lookup)))))
(string-join (map (lambda (x) (apply glyph-spec x))
- (reverse w-h-x-y-named-glyphs)) "\n")))
+ (reverse w-h-x-y-named-glyphs)) "\n")))
(define glyph-string
(if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
(define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
(define (convert-path-exps exps)
(if (pair? exps)
- (let*
- ((head (car exps))
- (rest (cdr exps))
- (arity
- (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
- ((memq head '(rcurveto curveto)) 6)
- ((eq? head 'closepath) 0)
- (else 1)))
- (args (take rest arity))
- (svg-head (assoc-get head
- '((rmoveto . m)
- (rcurveto . c)
- (curveto . C)
- (moveto . M)
- (lineto . L)
- (rlineto . l)
- (closepath . z))
- "")))
-
- (cons (format #f "~a~a" svg-head (number-list->point args))
- (convert-path-exps (drop rest arity))))
- '()))
+ (let*
+ ((head (car exps))
+ (rest (cdr exps))
+ (arity
+ (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
+ ((memq head '(rcurveto curveto)) 6)
+ ((eq? head 'closepath) 0)
+ (else 1)))
+ (args (take rest arity))
+ (svg-head (assoc-get head
+ '((rmoveto . m)
+ (rcurveto . c)
+ (curveto . C)
+ (moveto . M)
+ (lineto . L)
+ (rlineto . l)
+ (closepath . z))
+ "")))
+
+ (cons (format #f "~a~a" svg-head (number-list->point args))
+ (convert-path-exps (drop rest arity))))
+ '()))
(let* ((line-cap-styles '(butt round square))
- (line-join-styles '(miter round bevel))
- (cap-style (if (not (memv cap line-cap-styles))
- (begin
- (ly:warning (_ "unknown line-cap-style: ~S")
- (symbol->string cap))
- 'round)
- cap))
- (join-style (if (not (memv join line-join-styles))
- (begin
- (ly:warning (_ "unknown line-join-style: ~S")
- (symbol->string join))
- 'round)
- join)))
+ (line-join-styles '(miter round bevel))
+ (cap-style (if (not (memv cap line-cap-styles))
+ (begin
+ (ly:warning (_ "unknown line-cap-style: ~S")
+ (symbol->string cap))
+ 'round)
+ cap))
+ (join-style (if (not (memv join line-join-styles))
+ (begin
+ (ly:warning (_ "unknown line-join-style: ~S")
+ (symbol->string join))
+ 'round)
+ join)))
(entity 'path ""
- `(stroke-width . ,thick)
- `(stroke-linejoin . ,(symbol->string join-style))
- `(stroke-linecap . ,(symbol->string cap-style))
- '(stroke . "currentColor")
- `(fill . ,(if fill? "currentColor" "none"))
- `(d . ,(apply string-append (convert-path-exps commands))))))
+ `(stroke-width . ,thick)
+ `(stroke-linejoin . ,(symbol->string join-style))
+ `(stroke-linecap . ,(symbol->string cap-style))
+ '(stroke . "currentColor")
+ `(fill . ,(if fill? "currentColor" "none"))
+ `(d . ,(apply string-append (convert-path-exps commands))))))
(define (placebox x y expr)
(if (string-null? expr)
""
(let*
- ((normal-element (regexp-exec svg-element-regexp expr))
- (scaled-element (regexp-exec scaled-element-regexp expr))
- (scaled? (if scaled-element #t #f))
- (match (if scaled? scaled-element normal-element))
- (string1 (match:substring match 1))
- (string2 (match:substring match 2)))
-
- (if scaled?
- (string-append string1
- (ly:format "translate(~4f, ~4f) " x (- y))
- string2
- "\n")
- (string-append string1
- (ly:format " transform=\"translate(~4f, ~4f)\" "
- x (- y))
- string2
- "\n")))))
+ ((normal-element (regexp-exec svg-element-regexp expr))
+ (scaled-element (regexp-exec scaled-element-regexp expr))
+ (scaled? (if scaled-element #t #f))
+ (match (if scaled? scaled-element normal-element))
+ (string1 (match:substring match 1))
+ (string2 (match:substring match 2)))
+
+ (if scaled?
+ (string-append string1
+ (ly:format "translate(~4f, ~4f) " x (- y))
+ string2
+ "\n")
+ (string-append string1
+ (ly:format " transform=\"translate(~4f, ~4f)\" "
+ x (- y))
+ string2
+ "\n")))))
(define (polygon coords blot-diameter is-filled)
(entity
- 'polygon ""
- '(stroke-linejoin . "round")
- '(stroke-linecap . "round")
- `(stroke-width . ,blot-diameter)
- `(fill . ,(if is-filled "currentColor" "none"))
- '(stroke . "currentColor")
- `(points . ,(string-join
- (map offset->point (ly:list->offsets '() coords))))))
+ 'polygon ""
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(stroke-width . ,blot-diameter)
+ `(fill . ,(if is-filled "currentColor" "none"))
+ '(stroke . "currentColor")
+ `(points . ,(string-join
+ (map offset->point (ly:list->offsets '() coords))))))
(define (resetcolor)
"</g>\n")
(define (round-filled-box breapth width depth height blot-diameter)
(entity
- 'rect ""
- ;; The stroke will stick out. To use stroke,
- ;; the stroke-width must be subtracted from all other dimensions.
- ;;'(stroke-linejoin . "round")
- ;;'(stroke-linecap . "round")
- ;;`(stroke-width . ,blot)
- ;;'(stroke . "red")
- ;;'(fill . "orange")
-
- `(x . ,(- breapth))
- `(y . ,(- height))
- `(width . ,(+ breapth width))
- `(height . ,(+ depth height))
- `(ry . ,(/ blot-diameter 2))
- '(fill . "currentColor")))
+ 'rect ""
+ ;; The stroke will stick out. To use stroke,
+ ;; the stroke-width must be subtracted from all other dimensions.
+ ;;'(stroke-linejoin . "round")
+ ;;'(stroke-linecap . "round")
+ ;;`(stroke-width . ,blot)
+ ;;'(stroke . "red")
+ ;;'(fill . "orange")
+
+ `(x . ,(- breapth))
+ `(y . ,(- height))
+ `(width . ,(+ breapth width))
+ `(height . ,(+ depth height))
+ `(ry . ,(/ blot-diameter 2))
+ '(fill . "currentColor")))
(define (setcolor r g b)
(format #f "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
- (* 100 r) (* 100 g) (* 100 b)))
+ (* 100 r) (* 100 g) (* 100 b)))
;; rotate around given point
(define (setrotation ang x y)
(ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
- (- ang) x (- y)))
+ (- ang) x (- y)))
(define (setscale x y)
(ly:format "<g transform=\"scale(~4f, ~4f)\">\n"
- x y))
+ x y))
(define (text font string)
(fontify font (entity 'tspan (string->entities string))))
(string-append
(eo 'a `(xlink:href . ,url))
(eoc 'rect
- `(x . ,(car x))
- `(y . ,(car y))
- `(width . ,(- (cdr x) (car x)))
- `(height . ,(- (cdr y) (car y)))
- '(fill . "none")
- '(stroke . "none")
- '(stroke-width . "0.0"))
+ `(x . ,(car x))
+ `(y . ,(car y))
+ `(width . ,(- (cdr x) (car x)))
+ `(height . ,(- (cdr y) (car y)))
+ '(fill . "none")
+ '(stroke . "none")
+ '(stroke-width . "0.0"))
(ec 'a)))
(define (utf-8-string pango-font-description string)
(let ((escaped-string (string-regexp-substitute
- "<" "<"
- (string-regexp-substitute "&" "&" string))))
+ "<" "<"
+ (string-regexp-substitute "&" "&" string))))
(fontify pango-font-description
(entity 'tspan escaped-string))))
(define-module (scm page)
#:export (make-page
- page-property
- page-set-property!
- page-prev
- page-printable-height
- layout->page-init
- page-force
- page-penalty
- page-configuration
- page-lines
- page-page-number
- page-system-numbers
- page-stencil
- page-free-height
- page?
- ))
+ page-property
+ page-set-property!
+ page-prev
+ page-printable-height
+ layout->page-init
+ page-force
+ page-penalty
+ page-configuration
+ page-lines
+ page-page-number
+ page-system-numbers
+ page-stencil
+ page-free-height
+ page?
+ ))
(use-modules (lily)
- (scm paper-system)
- (srfi srfi-1))
+ (scm paper-system)
+ (srfi srfi-1))
(define (annotate? layout)
(define (make-page paper-book . args)
(let*
((p (apply ly:make-prob (append
- (list 'page (layout->page-init (ly:paper-book-paper paper-book))
- 'paper-book paper-book)
- args))))
+ (list 'page (layout->page-init (ly:paper-book-paper paper-book))
+ 'paper-book paper-book)
+ args))))
(page-set-property! p 'head-stencil (page-header p))
(page-set-property! p 'foot-stencil (page-footer p))
(lambda (sys-off)
(let*
- ((sys (car sys-off))
- (off (cadr sys-off)))
+ ((sys (car sys-off))
+ (off (cadr sys-off)))
(if (not (number? (ly:prob-property sys 'Y-offset)))
- (ly:prob-set-property! sys 'Y-offset off))))
+ (ly:prob-set-property! sys 'Y-offset off))))
(zip (page-property page 'lines)
- (page-property page 'configuration))))
+ (page-property page 'configuration))))
(define (annotate-top-space first-system layout header-stencil stencil)
(let* ((top-margin (ly:output-def-lookup layout 'top-margin))
- (sym (if (paper-system-title? first-system)
- 'top-markup-spacing
- 'top-system-spacing))
- (spacing-spec (ly:output-def-lookup layout sym))
- (X-offset (ly:prob-property first-system 'X-offset 5))
- (header-extent (ly:stencil-extent header-stencil Y)))
+ (sym (if (paper-system-title? first-system)
+ 'top-markup-spacing
+ 'top-system-spacing))
+ (spacing-spec (ly:output-def-lookup layout sym))
+ (X-offset (ly:prob-property first-system 'X-offset 5))
+ (header-extent (ly:stencil-extent header-stencil Y)))
(set! stencil
- (ly:stencil-add stencil
- (ly:stencil-translate-axis
- (annotate-spacing-spec layout
- spacing-spec
- (- top-margin)
- (car header-extent)
- #:base-color red)
- X-offset X)))
+ (ly:stencil-add stencil
+ (ly:stencil-translate-axis
+ (annotate-spacing-spec layout
+ spacing-spec
+ (- top-margin)
+ (car header-extent)
+ #:base-color red)
+ X-offset X)))
stencil))
(define (annotate-page layout stencil)
(let ((top-margin (ly:output-def-lookup layout 'top-margin))
- (paper-height (ly:output-def-lookup layout 'paper-height))
- (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
- (add-stencil (lambda (y)
- (set! stencil
- (ly:stencil-add stencil
- (ly:stencil-translate-axis y 6 X))))))
+ (paper-height (ly:output-def-lookup layout 'paper-height))
+ (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
+ (add-stencil (lambda (y)
+ (set! stencil
+ (ly:stencil-add stencil
+ (ly:stencil-translate-axis y 6 X))))))
(add-stencil
(ly:stencil-translate-axis
(annotate-y-interval layout "paper-height"
- (cons (- paper-height) 0)
- #t)
+ (cons (- paper-height) 0)
+ #t)
1 X))
(add-stencil
(ly:stencil-translate-axis
(annotate-y-interval layout "top-margin"
- (cons (- top-margin) 0)
- #t)
+ (cons (- top-margin) 0)
+ #t)
2 X))
(add-stencil
(ly:stencil-translate-axis
(annotate-y-interval layout "bottom-margin"
- (cons (- paper-height) (- bottom-margin paper-height))
- #t)
+ (cons (- paper-height) (- bottom-margin paper-height))
+ #t)
2 X))
stencil))
((paper-book (page-property page 'paper-book))
(layout (ly:paper-book-paper paper-book))
(arrow (annotate-y-interval layout
- "space left"
- (cons (- 0.0
- (page-property page 'bottom-edge)
- (let ((foot (page-property page 'foot-stencil)))
- (if (and (ly:stencil? foot)
- (not (ly:stencil-empty? foot)))
- (car (ly:stencil-extent foot Y))
- 0.0)))
- (page-property page 'bottom-system-edge))
- #t)))
+ "space left"
+ (cons (- 0.0
+ (page-property page 'bottom-edge)
+ (let ((foot (page-property page 'foot-stencil)))
+ (if (and (ly:stencil? foot)
+ (not (ly:stencil-empty? foot)))
+ (car (ly:stencil-extent foot Y))
+ 0.0)))
+ (page-property page 'bottom-system-edge))
+ #t)))
(set! arrow (ly:stencil-translate-axis arrow 8 X))
(is-last-bookpart (page-property page 'is-last-bookpart))
(is-bookpart-last-page (page-property page 'is-bookpart-last-page))
(sym (if (= dir UP)
- 'make-header
- 'make-footer))
+ 'make-header
+ 'make-footer))
(header-proc (ly:output-def-lookup layout sym)))
(if (procedure? header-proc)
- (header-proc layout scopes number is-last-bookpart is-bookpart-last-page)
- #f)))
+ (header-proc layout scopes number is-last-bookpart is-bookpart-last-page)
+ #f)))
(define (page-header page)
(left-margin (ly:output-def-lookup layout 'left-margin))
(right-margin (ly:output-def-lookup layout 'right-margin))
(bottom-edge (- paper-height
- (ly:output-def-lookup layout 'bottom-margin)) )
+ (ly:output-def-lookup layout 'bottom-margin)) )
(top-margin (ly:output-def-lookup layout 'top-margin))
)
(system-xoffset (ly:output-def-lookup layout 'horizontal-shift 0.0))
(system-separator-markup (ly:output-def-lookup layout 'system-separator-markup))
(system-separator-stencil (if (markup? system-separator-markup)
- (interpret-markup layout
- (layout-extract-page-properties layout)
- system-separator-markup)
- #f))
+ (interpret-markup layout
+ (layout-extract-page-properties layout)
+ system-separator-markup)
+ #f))
(page-stencil (ly:make-stencil '()))
(last-system #f)
(last-y 0.0)
(add-to-page (lambda (stencil x y)
- (set! page-stencil
- (ly:stencil-add page-stencil
- (ly:stencil-translate stencil
- (cons
- (+ system-xoffset x)
- (- 0 y (prop 'top-margin)))
-
- )))))
+ (set! page-stencil
+ (ly:stencil-add page-stencil
+ (ly:stencil-translate stencil
+ (cons
+ (+ system-xoffset x)
+ (- 0 y (prop 'top-margin)))
+
+ )))))
(add-system
- (lambda (system)
- (let* ((stencil (paper-system-stencil system))
- (y (ly:prob-property system 'Y-offset 0))
- (is-title (paper-system-title?
- system)))
- (add-to-page stencil
- (ly:prob-property system 'X-offset 0.0)
- y)
- (if (and (ly:stencil? system-separator-stencil)
- last-system
- (not (paper-system-title? system))
- (not (paper-system-title? last-system)))
- (add-to-page
- system-separator-stencil
- 0
- (average (- last-y
- (car (paper-system-staff-extents last-system)))
- (- y
- (cdr (paper-system-staff-extents system))))))
- (set! last-system system)
- (set! last-y y))))
+ (lambda (system)
+ (let* ((stencil (paper-system-stencil system))
+ (y (ly:prob-property system 'Y-offset 0))
+ (is-title (paper-system-title?
+ system)))
+ (add-to-page stencil
+ (ly:prob-property system 'X-offset 0.0)
+ y)
+ (if (and (ly:stencil? system-separator-stencil)
+ last-system
+ (not (paper-system-title? system))
+ (not (paper-system-title? last-system)))
+ (add-to-page
+ system-separator-stencil
+ 0
+ (average (- last-y
+ (car (paper-system-staff-extents last-system)))
+ (- y
+ (cdr (paper-system-staff-extents system))))))
+ (set! last-system system)
+ (set! last-y y))))
(head (prop 'head-stencil))
(foot (prop 'foot-stencil))
)
(if (and
- (ly:stencil? head)
- (not (ly:stencil-empty? head)))
- (begin
- ;; Ensure that the top of the header just touches the top margin.
- (set! head (ly:stencil-translate-axis head
- (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y))
- (set! page-stencil (ly:stencil-add page-stencil head))))
+ (ly:stencil? head)
+ (not (ly:stencil-empty? head)))
+ (begin
+ ;; Ensure that the top of the header just touches the top margin.
+ (set! head (ly:stencil-translate-axis head
+ (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y))
+ (set! page-stencil (ly:stencil-add page-stencil head))))
(if (and
- (annotate? layout)
- (pair? lines))
+ (annotate? layout)
+ (pair? lines))
- (begin
- (set! page-stencil (annotate-top-space (car lines) layout head page-stencil))
+ (begin
+ (set! page-stencil (annotate-top-space (car lines) layout head page-stencil))
- (for-each (lambda (sys next-sys)
- (paper-system-annotate sys next-sys layout))
- lines
- (append (cdr lines) (list #f)))
- (paper-system-annotate-last (car (last-pair lines)) layout)))
+ (for-each (lambda (sys next-sys)
+ (paper-system-annotate sys next-sys layout))
+ lines
+ (append (cdr lines) (list #f)))
+ (paper-system-annotate-last (car (last-pair lines)) layout)))
(map add-system lines)
(ly:prob-set-property! page 'bottom-system-edge
- (car (ly:stencil-extent page-stencil Y)))
+ (car (ly:stencil-extent page-stencil Y)))
(ly:prob-set-property! page 'space-left
- (+ (prop 'bottom-edge)
- (prop 'bottom-system-edge)
- (if (and (ly:stencil? foot)
- (not (ly:stencil-empty? foot)))
- (car (ly:stencil-extent foot Y))
- 0.0)))
+ (+ (prop 'bottom-edge)
+ (prop 'bottom-system-edge)
+ (if (and (ly:stencil? foot)
+ (not (ly:stencil-empty? foot)))
+ (car (ly:stencil-extent foot Y))
+ 0.0)))
(if (annotate? layout)
- (set! page-stencil
- (ly:stencil-add page-stencil
- (annotate-space-left page))))
+ (set! page-stencil
+ (ly:stencil-add page-stencil
+ (annotate-space-left page))))
(if (and (ly:stencil? foot)
- (not (ly:stencil-empty? foot)))
- (set! page-stencil
- (ly:stencil-add
- page-stencil
- (ly:stencil-translate
- foot
- (cons 0
- (+ (- (prop 'bottom-edge))
- (- (car (ly:stencil-extent foot Y)))))))))
+ (not (ly:stencil-empty? foot)))
+ (set! page-stencil
+ (ly:stencil-add
+ page-stencil
+ (ly:stencil-translate
+ foot
+ (cons 0
+ (+ (- (prop 'bottom-edge))
+ (- (car (ly:stencil-extent foot Y)))))))))
(if (ly:output-def-lookup layout 'two-sided #f)
- (set! page-stencil
- (ly:stencil-translate page-stencil
- (cons (prop (if (even? number)
- 'left-margin
- 'right-margin))
- 0)))
- (set! page-stencil
- (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0))))
+ (set! page-stencil
+ (ly:stencil-translate page-stencil
+ (cons (prop (if (even? number)
+ 'left-margin
+ 'right-margin))
+ 0)))
+ (set! page-stencil
+ (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0))))
;; annotation.
(if (annotate? layout)
- (set! page-stencil (annotate-page layout page-stencil)))
+ (set! page-stencil (annotate-page layout page-stencil)))
page-stencil))
((paper-book (page-property page 'paper-book))
(layout (ly:paper-book-paper paper-book))
(h (- (ly:output-def-lookup layout 'paper-height)
- (ly:output-def-lookup layout 'top-margin)
- (ly:output-def-lookup layout 'bottom-margin)))
+ (ly:output-def-lookup layout 'top-margin)
+ (ly:output-def-lookup layout 'bottom-margin)))
(head (page-property page 'head-stencil))
(foot (page-property page 'foot-stencil))
(available
- (- h (if (ly:stencil? head)
- (interval-length (ly:stencil-extent head Y))
- 0)
- (if (ly:stencil? foot)
- (interval-length (ly:stencil-extent foot Y))
- 0))))
+ (- h (if (ly:stencil? head)
+ (interval-length (ly:stencil-extent head Y))
+ 0)
+ (if (ly:stencil? foot)
+ (interval-length (ly:stencil-extent foot Y))
+ 0))))
;; (display (list "\n available" available head foot))
available))
(page-set-property! page 'printable-height (calc-printable-height page)))
(page-property page 'printable-height))
-
(define-module (scm paper-system))
(use-modules (lily)
- (srfi srfi-1)
- (ice-9 optargs))
+ (srfi srfi-1)
+ (ice-9 optargs))
(define-public (paper-system-title? system)
(equal? #t (ly:prob-property system 'is-title)
- ))
+ ))
(define (system-stencil system-grob main-stencil)
(let* ((padding (ly:grob-property system-grob 'in-note-padding #f))
(in-notes (if in-notes in-notes empty-stencil))
(direction (if padding (ly:grob-property system-grob 'in-note-direction) UP)))
(if padding
- (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding)
- main-stencil)))
+ (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding)
+ main-stencil)))
(define-public (paper-system-stencil system)
(let ((main-stencil (ly:prob-property system 'stencil))
((g (paper-system-system-grob system)))
(if (ly:grob? g)
- (ly:grob-layout g)
- #f)))
+ (ly:grob-layout g)
+ #f)))
(define-public (paper-system-system-grob paper-system)
(ly:prob-property paper-system 'system-grob))
(y-extent (paper-system-extent system Y))
(x-extent (paper-system-extent system X))
(stencil (ly:prob-property system 'stencil))
-
+
(arrow (if (number? bottomspace)
- (annotate-y-interval layout
- "bottom-space"
- (cons (- (car y-extent) bottomspace)
- (car y-extent))
- #t)
- #f)))
-
+ (annotate-y-interval layout
+ "bottom-space"
+ (cons (- (car y-extent) bottomspace)
+ (car y-extent))
+ #t)
+ #f)))
+
(if arrow
- (set! stencil
- (ly:stencil-add stencil arrow)))
+ (set! stencil
+ (ly:stencil-add stencil arrow)))
(set! (ly:prob-property system 'stencil)
- stencil)
- ))
+ stencil)
+ ))
;; Y-ext and next-Y-ext are either skyline-pairs or extents
(define*-public (annotate-padding system-Y system-X Y-ext X-ext
- next-system-Y next-system-X next-Y-ext next-X-ext
- layout horizon-padding padding #:key (base-color blue))
+ next-system-Y next-system-X next-Y-ext next-X-ext
+ layout horizon-padding padding #:key (base-color blue))
(let* ((eps 0.001)
- (skyline (and (ly:skyline-pair? Y-ext)
- (ly:skyline-pair::skyline Y-ext DOWN)))
- (next-skyline (and (ly:skyline-pair? next-Y-ext)
- (ly:skyline-pair::skyline next-Y-ext UP)))
- (annotation-X (cond
- ((and skyline next-skyline)
- (-
- (ly:skyline::get-touching-point skyline next-skyline horizon-padding)
- horizon-padding))
- (skyline
- (ly:skyline::get-max-height-position skyline))
- (next-skyline
- (ly:skyline::get-max-height-position next-skyline))
- (else
- (max (cdr X-ext)
- (cdr next-X-ext)))))
- (annotation-Y (if skyline
- (ly:skyline::get-height skyline annotation-X)
- (car Y-ext)))
- (next-annotation-Y (if next-skyline
- (- (+ (ly:skyline::get-height next-skyline
- (- (+ annotation-X system-X)
- next-system-X))
- next-system-Y)
- system-Y)
- (cdr next-Y-ext)))
- (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
- (contrast-color (append (cdr base-color) (list (car base-color))))
- (color (if padding-blocks contrast-color base-color))
- (annotation (ly:stencil-translate-axis
- (annotate-y-interval
- layout
- "padding"
- `(,(- annotation-Y padding). ,annotation-Y)
- #t
- #:color color)
- annotation-X X)))
+ (skyline (and (ly:skyline-pair? Y-ext)
+ (ly:skyline-pair::skyline Y-ext DOWN)))
+ (next-skyline (and (ly:skyline-pair? next-Y-ext)
+ (ly:skyline-pair::skyline next-Y-ext UP)))
+ (annotation-X (cond
+ ((and skyline next-skyline)
+ (-
+ (ly:skyline::get-touching-point skyline next-skyline horizon-padding)
+ horizon-padding))
+ (skyline
+ (ly:skyline::get-max-height-position skyline))
+ (next-skyline
+ (ly:skyline::get-max-height-position next-skyline))
+ (else
+ (max (cdr X-ext)
+ (cdr next-X-ext)))))
+ (annotation-Y (if skyline
+ (ly:skyline::get-height skyline annotation-X)
+ (car Y-ext)))
+ (next-annotation-Y (if next-skyline
+ (- (+ (ly:skyline::get-height next-skyline
+ (- (+ annotation-X system-X)
+ next-system-X))
+ next-system-Y)
+ system-Y)
+ (cdr next-Y-ext)))
+ (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
+ (contrast-color (append (cdr base-color) (list (car base-color))))
+ (color (if padding-blocks contrast-color base-color))
+ (annotation (ly:stencil-translate-axis
+ (annotate-y-interval
+ layout
+ "padding"
+ `(,(- annotation-Y padding). ,annotation-Y)
+ #t
+ #:color color)
+ annotation-X X)))
(if (> padding 0.0)
- annotation
- empty-stencil)))
+ annotation
+ empty-stencil)))
+
-
(define-public (paper-system-annotate system next-system layout)
"Add arrows and texts to indicate which lengths are set."
(let* ((grob (ly:prob-property system 'system-grob))
- (paper-height (ly:output-def-lookup layout 'paper-height))
- (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
- (top-margin (ly:output-def-lookup layout 'top-margin))
- (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
- (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
- (spaceable-staff-annotate
- (lambda (before-staff after-staff)
- (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
- (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
- (annotate-spacing-spec
- layout
- (ly:get-spacing-spec before-staff after-staff)
- before-Y
- after-Y))))
+ (paper-height (ly:output-def-lookup layout 'paper-height))
+ (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
+ (top-margin (ly:output-def-lookup layout 'top-margin))
+ (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
+ (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
+ (spaceable-staff-annotate
+ (lambda (before-staff after-staff)
+ (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
+ (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
+ (annotate-spacing-spec
+ layout
+ (ly:get-spacing-spec before-staff after-staff)
+ before-Y
+ after-Y))))
- (staff-padding-annotate
- (lambda (before-staff after-staff)
- (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
- (before-X (ly:grob-relative-coordinate before-staff grob X))
- (before-X-ext (ly:grob-extent before-staff before-staff X))
- (after-Y (ly:grob-relative-coordinate after-staff grob Y))
- (after-X (ly:grob-relative-coordinate after-staff grob X))
- (after-X-ext (ly:grob-extent after-staff after-staff X))
- (skylines (ly:grob-property before-staff 'vertical-skylines))
- (after-skylines (ly:grob-property after-staff 'vertical-skylines))
- (padding (assoc-get 'padding
- (ly:get-spacing-spec before-staff after-staff)
- 0.0))
- (horizon-padding (ly:grob-property before-staff
- 'skyline-horizontal-padding
- 0.0)))
- (ly:stencil-translate
- (annotate-padding
- before-Y before-X skylines before-X-ext
- after-Y after-X after-skylines after-X-ext
- layout horizon-padding padding)
- (cons before-X before-Y)))))
+ (staff-padding-annotate
+ (lambda (before-staff after-staff)
+ (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
+ (before-X (ly:grob-relative-coordinate before-staff grob X))
+ (before-X-ext (ly:grob-extent before-staff before-staff X))
+ (after-Y (ly:grob-relative-coordinate after-staff grob Y))
+ (after-X (ly:grob-relative-coordinate after-staff grob X))
+ (after-X-ext (ly:grob-extent after-staff after-staff X))
+ (skylines (ly:grob-property before-staff 'vertical-skylines))
+ (after-skylines (ly:grob-property after-staff 'vertical-skylines))
+ (padding (assoc-get 'padding
+ (ly:get-spacing-spec before-staff after-staff)
+ 0.0))
+ (horizon-padding (ly:grob-property before-staff
+ 'skyline-horizontal-padding
+ 0.0)))
+ (ly:stencil-translate
+ (annotate-padding
+ before-Y before-X skylines before-X-ext
+ after-Y after-X after-skylines after-X-ext
+ layout horizon-padding padding)
+ (cons before-X before-Y)))))
- (staff-annotations (if (< 1 (length spaceable-staves))
- (map spaceable-staff-annotate
- (drop-right spaceable-staves 1)
- (drop spaceable-staves 1))
- '()))
- (staff-padding-annotations (if (< 1 (length all-staves))
- (map staff-padding-annotate
- (drop-right all-staves 1)
- (drop all-staves 1))
- '()))
- (estimate-extent (if (ly:grob? grob)
- (annotate-y-interval layout
- "extent-estimate"
- (ly:grob-property grob 'pure-Y-extent)
- #f)
- #f))
+ (staff-annotations (if (< 1 (length spaceable-staves))
+ (map spaceable-staff-annotate
+ (drop-right spaceable-staves 1)
+ (drop spaceable-staves 1))
+ '()))
+ (staff-padding-annotations (if (< 1 (length all-staves))
+ (map staff-padding-annotate
+ (drop-right all-staves 1)
+ (drop all-staves 1))
+ '()))
+ (estimate-extent (if (ly:grob? grob)
+ (annotate-y-interval layout
+ "extent-estimate"
+ (ly:grob-property grob 'pure-Y-extent)
+ #f)
+ #f))
- (spacing-spec (cond ((and next-system
- (paper-system-title? system)
- (paper-system-title? next-system))
- (ly:output-def-lookup layout 'markup-markup-spacing))
- ((paper-system-title? system)
- (ly:output-def-lookup layout 'markup-system-spacing))
- ((and next-system
- (paper-system-title? next-system))
- (ly:output-def-lookup layout 'score-markup-spacing))
- ((not next-system)
- (ly:output-def-lookup layout 'last-bottom-spacing))
- ((ly:prob-property system 'last-in-score #f)
- (ly:output-def-lookup layout 'score-system-spacing))
- (else
- (ly:output-def-lookup layout 'system-system-spacing))))
- (last-staff-Y (car (paper-system-staff-extents system)))
- (system-Y (ly:prob-property system 'Y-offset 0.0))
- (system-X (ly:prob-property system 'X-offset 0.0))
- (next-system-Y (and next-system
- (ly:prob-property next-system 'Y-offset 0.0)))
- (next-system-X (and next-system
- (ly:prob-property next-system 'X-offset 0.0)))
- (first-staff-next-system-Y (if next-system
- (- (+ (cdr (paper-system-staff-extents next-system))
- system-Y)
- next-system-Y)
- (+ system-Y top-margin bottom-margin (- paper-height))))
+ (spacing-spec (cond ((and next-system
+ (paper-system-title? system)
+ (paper-system-title? next-system))
+ (ly:output-def-lookup layout 'markup-markup-spacing))
+ ((paper-system-title? system)
+ (ly:output-def-lookup layout 'markup-system-spacing))
+ ((and next-system
+ (paper-system-title? next-system))
+ (ly:output-def-lookup layout 'score-markup-spacing))
+ ((not next-system)
+ (ly:output-def-lookup layout 'last-bottom-spacing))
+ ((ly:prob-property system 'last-in-score #f)
+ (ly:output-def-lookup layout 'score-system-spacing))
+ (else
+ (ly:output-def-lookup layout 'system-system-spacing))))
+ (last-staff-Y (car (paper-system-staff-extents system)))
+ (system-Y (ly:prob-property system 'Y-offset 0.0))
+ (system-X (ly:prob-property system 'X-offset 0.0))
+ (next-system-Y (and next-system
+ (ly:prob-property next-system 'Y-offset 0.0)))
+ (next-system-X (and next-system
+ (ly:prob-property next-system 'X-offset 0.0)))
+ (first-staff-next-system-Y (if next-system
+ (- (+ (cdr (paper-system-staff-extents next-system))
+ system-Y)
+ next-system-Y)
+ (+ system-Y top-margin bottom-margin (- paper-height))))
- (skyline (or
- (ly:prob-property system 'vertical-skylines #f)
- (paper-system-extent system Y)))
- (next-skyline (and next-system
- (or
- (ly:prob-property next-system 'vertical-skylines #f)
- (paper-system-extent next-system Y))))
- (horizon-padding (and
- (ly:grob? grob)
- (ly:grob-property grob 'skyline-horizontal-padding 0)))
- (padding-annotation (if (skyline-pair-and-non-empty? next-system)
- (annotate-padding
- (- system-Y) system-X skyline (paper-system-extent system X)
- (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
- layout
- horizon-padding
- (assoc-get 'padding spacing-spec 0.0)
- #:base-color blue)
- empty-stencil))
+ (skyline (or
+ (ly:prob-property system 'vertical-skylines #f)
+ (paper-system-extent system Y)))
+ (next-skyline (and next-system
+ (or
+ (ly:prob-property next-system 'vertical-skylines #f)
+ (paper-system-extent next-system Y))))
+ (horizon-padding (and
+ (ly:grob? grob)
+ (ly:grob-property grob 'skyline-horizontal-padding 0)))
+ (padding-annotation (if (skyline-pair-and-non-empty? next-system)
+ (annotate-padding
+ (- system-Y) system-X skyline (paper-system-extent system X)
+ (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
+ layout
+ horizon-padding
+ (assoc-get 'padding spacing-spec 0.0)
+ #:base-color blue)
+ empty-stencil))
- (system-annotation (annotate-spacing-spec
- layout spacing-spec
- last-staff-Y
- first-staff-next-system-Y))
- (annotations (ly:stencil-add
- padding-annotation
- (stack-stencils Y DOWN 0.0 staff-padding-annotations)
- (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
+ (system-annotation (annotate-spacing-spec
+ layout spacing-spec
+ last-staff-Y
+ first-staff-next-system-Y))
+ (annotations (ly:stencil-add
+ padding-annotation
+ (stack-stencils Y DOWN 0.0 staff-padding-annotations)
+ (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
- (if estimate-extent
- (set! annotations
- (stack-stencils X RIGHT 5.5
- (list annotations
- estimate-extent))))
+ (if estimate-extent
+ (set! annotations
+ (stack-stencils X RIGHT 5.5
+ (list annotations
+ estimate-extent))))
- (if (not (null? annotations))
- (set! (ly:prob-property system 'stencil)
- (ly:stencil-add
- (ly:prob-property system 'stencil)
- (ly:make-stencil
- (ly:stencil-expr annotations)
- (ly:stencil-extent empty-stencil X)
- (ly:stencil-extent empty-stencil Y)))))
- (ly:prob-property system 'stencil)))
+ (if (not (null? annotations))
+ (set! (ly:prob-property system 'stencil)
+ (ly:stencil-add
+ (ly:prob-property system 'stencil)
+ (ly:make-stencil
+ (ly:stencil-expr annotations)
+ (ly:stencil-extent empty-stencil X)
+ (ly:stencil-extent empty-stencil Y)))))
+ (ly:prob-property system 'stencil)))
(define-public (set-paper-dimension-variables mod)
(module-define! mod 'dimension-variables
- '(blot-diameter
- bottom-margin
- cm
- footnote-footer-padding
- footnote-padding
- horizontal-shift
- in
- indent
- inner-margin
- inner-margin-default-scaled
- ledger-line-thickness
- left-margin
+ '(blot-diameter
+ bottom-margin
+ cm
+ footnote-footer-padding
+ footnote-padding
+ horizontal-shift
+ in
+ indent
+ inner-margin
+ inner-margin-default-scaled
+ ledger-line-thickness
+ left-margin
left-margin-default-scaled
- line-thickness
- line-width
- mm
- outer-margin
- outer-margin-default-scaled
- paper-height
- paper-width
- pt
- right-margin
+ line-thickness
+ line-width
+ mm
+ outer-margin
+ outer-margin-default-scaled
+ paper-height
+ paper-width
+ pt
+ right-margin
right-margin-default-scaled
- short-indent
- staff-height
- staff-space
- top-margin)))
+ short-indent
+ staff-height
+ staff-space
+ top-margin)))
(define (calc-line-thickness staff-space pt)
;; linear interpolation.
(ss (/ staff-height 4))
(factor (/ staff-height (* 20 pt)))
(setm! (lambda (sym val)
- (module-define! module sym val))))
+ (module-define! module sym val))))
;; Synchronized with the `text-font-size'
;; binding in add-pango-fonts (see font.scm).
(define-safe-public (set-global-staff-size sz)
"Set the default staff size, where SZ is thought to be in PT."
(let* ((current-mod (current-module))
- (parser (eval 'parser current-mod))
- (pap (ly:parser-lookup parser '$defaultpaper))
- (in-layout? (or (module-defined? current-mod 'is-paper)
- (module-defined? current-mod 'is-layout)))
-
- ;; maybe not necessary.
- ;; but let's be paranoid. Maybe someone still refers to the
- ;; old one.
- (new-paper (ly:output-def-clone pap))
+ (parser (eval 'parser current-mod))
+ (pap (ly:parser-lookup parser '$defaultpaper))
+ (in-layout? (or (module-defined? current-mod 'is-paper)
+ (module-defined? current-mod 'is-layout)))
+
+ ;; maybe not necessary.
+ ;; but let's be paranoid. Maybe someone still refers to the
+ ;; old one.
+ (new-paper (ly:output-def-clone pap))
- (new-scope (ly:output-def-scope new-paper)))
+ (new-scope (ly:output-def-scope new-paper)))
(if in-layout?
- (ly:warning (_ "set-global-staff-size: not in toplevel scope")))
+ (ly:warning (_ "set-global-staff-size: not in toplevel scope")))
(layout-set-absolute-staff-size-in-module new-scope
- (* sz (eval 'pt new-scope)))
+ (* sz (eval 'pt new-scope)))
(module-define! current-mod '$defaultpaper new-paper)))
(define-public paper-alist
where @var{landscape?} specifies whether the dimensions should be swapped
unless explicitly overriden in the name."
(let* ((swapped?
- (cond ((string-suffix? "landscape" name)
- (set! name
- (string-trim-right (string-drop-right name 9)))
- #t)
- ((string-suffix? "portrait" name)
- (set! name
- (string-trim-right (string-drop-right name 8)))
- #f)
- (else landscape?)))
- (is-paper? (module-defined? module 'is-paper))
- (entry (and is-paper?
+ (cond ((string-suffix? "landscape" name)
+ (set! name
+ (string-trim-right (string-drop-right name 9)))
+ #t)
+ ((string-suffix? "portrait" name)
+ (set! name
+ (string-trim-right (string-drop-right name 8)))
+ #f)
+ (else landscape?)))
+ (is-paper? (module-defined? module 'is-paper))
+ (entry (and is-paper?
(eval-carefully (assoc-get name paper-alist)
module
#f))))
;; Output_def::normalize () needs to know
;; whether the user set the value or not.
(scaleable-values '(("left-margin" #f . #t)
- ("right-margin" #f . #t)
- ("inner-margin" #f . #t)
- ("outer-margin" #f . #t)
- ("binding-offset" #f . #f)
- ("top-margin" #t . #f)
- ("bottom-margin" #t . #f)
- ("indent" #f . #f)
- ("short-indent" #f . #f)))
+ ("right-margin" #f . #t)
+ ("inner-margin" #f . #t)
+ ("outer-margin" #f . #t)
+ ("binding-offset" #f . #f)
+ ("top-margin" #t . #f)
+ ("bottom-margin" #t . #f)
+ ("indent" #f . #f)
+ ("short-indent" #f . #f)))
(scaled-values
- (map
+ (map
(lambda (entry)
(let ((entry-symbol
- (string->symbol
- (string-append (car entry) "-default")))
- (vertical? (cadr entry)))
+ (string->symbol
+ (string-append (car entry) "-default")))
+ (vertical? (cadr entry)))
(cons (if (cddr entry)
(string-append (car entry) "-default-scaled")
(car entry))
(for-each
(lambda (value)
(let ((value-symbol (string->symbol (car value)))
- (number (cdr value)))
- (module-define! m value-symbol number)))
+ (number (cdr value)))
+ (module-define! m value-symbol number)))
scaled-values)))
(define (internal-set-paper-size module name landscape?)
(ly:warning (_ "This is not a \\layout {} object, ~S") module))
(entry
(set-paper-dimensions module (car entry) (cdr entry) landscape?)
-
+
(module-define! module 'papersizename name)
(module-define! module 'landscape
- (if landscape? #t #f)))
+ (if landscape? #t #f)))
(else
(ly:warning (_ "Unknown paper size: ~a") name)))))
(define-public (set-paper-size name . rest)
(if (module-defined? (current-module) 'is-paper)
(internal-set-paper-size (current-module) name
- (memq 'landscape rest))
+ (memq 'landscape rest))
;;; TODO: should raise (generic) exception with throw, and catch
;;; that in parse-scm.cc
(define-public (scale-layout paper scale)
"Return a clone of the paper, scaled by the given scale factor."
(let* ((new-paper (ly:output-def-clone paper))
- (dim-vars (ly:output-def-lookup paper 'dimension-variables))
- (old-scope (ly:output-def-scope paper))
- (scope (ly:output-def-scope new-paper)))
+ (dim-vars (ly:output-def-lookup paper 'dimension-variables))
+ (old-scope (ly:output-def-scope paper))
+ (scope (ly:output-def-scope new-paper)))
(for-each
(lambda (v)
(let* ((var (module-variable old-scope v))
- (val (if (variable? var) (variable-ref var) #f)))
+ (val (if (variable? var) (variable-ref var) #f)))
- (if (number? val)
- (module-define! scope v (/ val scale))
- ;; Cannot warn for non-numbers, eg. for paper-width, paper-height.
- )))
+ (if (number? val)
+ (module-define! scope v (/ val scale))
+ ;; Cannot warn for non-numbers, eg. for paper-width, paper-height.
+ )))
dim-vars)
;; Mark the clone.
(ly:output-def-set-variable! new-paper 'cloned #t)
(map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props)
m))
(let ((e '())
- (c0 0)
- (oct 0)
- (style 'default)
- (match (string-match "^(.*)([_^])([^0-9a-zA-Z]*)([1-9][0-9]*)([^0-9a-zA-Z]*)$" clef-name)))
+ (c0 0)
+ (oct 0)
+ (style 'default)
+ (match (string-match "^(.*)([_^])([^0-9a-zA-Z]*)([1-9][0-9]*)([^0-9a-zA-Z]*)$" clef-name)))
(if match
- (begin
- (set! clef-name (match:substring match 1))
- (set! oct
- (* (if (equal? (match:substring match 2) "^") -1 1)
- (- (string->number (match:substring match 4)) 1)))
+ (begin
+ (set! clef-name (match:substring match 1))
+ (set! oct
+ (* (if (equal? (match:substring match 2) "^") -1 1)
+ (- (string->number (match:substring match 4)) 1)))
(set! style
(cond ((equal? (match:substring match 3) "(") 'parenthesized)
((equal? (match:substring match 3) "[") 'bracketed)
(else style)))))
(set! e (assoc-get clef-name supported-clefs))
(if e
- (let* ((prop-list `(((symbol . clefGlyph) (value . ,(car e)))
+ (let* ((prop-list `(((symbol . clefGlyph) (value . ,(car e)))
((symbol . middleCClefPosition)
(value . ,(+ oct
(cadr e)
(prop-list (if (eq? style 'default)
prop-list
(append
- prop-list
- `(((symbol . clefTranspositionStyle)
- (value . ,style))))))
- (musics (map make-prop-set prop-list))
- (recalc-mid-C (make-music 'ApplyContext))
- (seq (make-music 'SequentialMusic
- 'elements (append musics (list recalc-mid-C))))
- (csp (make-music 'ContextSpeccedMusic)))
- (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!)
- (context-spec-music seq 'Staff))
- (begin
- (ly:warning (_ "unknown clef type `~a'") clef-name)
- (ly:warning (_ "supported clefs: ~a")
- (string-join
- (sort (map car supported-clefs) string<?)))
- (make-music 'Music)))))
+ prop-list
+ `(((symbol . clefTranspositionStyle)
+ (value . ,style))))))
+ (musics (map make-prop-set prop-list))
+ (recalc-mid-C (make-music 'ApplyContext))
+ (seq (make-music 'SequentialMusic
+ 'elements (append musics (list recalc-mid-C))))
+ (csp (make-music 'ContextSpeccedMusic)))
+ (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!)
+ (context-spec-music seq 'Staff))
+ (begin
+ (ly:warning (_ "unknown clef type `~a'") clef-name)
+ (ly:warning (_ "supported clefs: ~a")
+ (string-join
+ (sort (map car supported-clefs) string<?)))
+ (make-music 'Music)))))
(define-public (make-cue-clef-set clef-name)
"Generate the clef setting commands for a cue clef with name
from @var{port} and return the corresponding Scheme music expression.
@samp{$} and @samp{#} introduce immediate and normal Scheme forms."
(let* ((closures '())
- (filename (port-filename port))
- (line (port-line port))
- (lily-string (call-with-output-string
- (lambda (out)
- (let ((copycat
- (make-soft-port
- (vector #f #f #f
- (lambda ()
- (let ((x (read-char port)))
- (write-char x out)
- x)) #f)
- "r")))
- (set-port-filename! copycat filename)
- (do ((c (read-char port) (read-char port)))
- ((and (char=? c #\#)
- (char=? (peek-char port) #\}))
- ;; we stop when #} is encountered
- (read-char port))
- (write-char c out)
- ;; a #scheme or $scheme expression
- (if (or (char=? c #\#) (char=? c #\$))
- (let* ((p (ftell out))
- (expr
- (begin
- (set-port-line! copycat
- (port-line port))
- (set-port-column! copycat
- (port-column port))
- (if (char=? (peek-char port) #\@)
- (read-char copycat))
- (read copycat))))
- ;; kill unused lookahead, it has been
- ;; written out already
- (drain-input copycat)
- ;; only put symbols and non-quote
- ;; lists into closures -- constants
- ;; don't need lexical environments
- ;; for evaluation.
- (if (or (symbol? expr)
- (and (pair? expr)
- (not (eq? 'quote (car expr)))))
- (set! closures
- (cons `(cons ,p (lambda () ,expr))
- closures)))))))))))
+ (filename (port-filename port))
+ (line (port-line port))
+ (lily-string (call-with-output-string
+ (lambda (out)
+ (let ((copycat
+ (make-soft-port
+ (vector #f #f #f
+ (lambda ()
+ (let ((x (read-char port)))
+ (write-char x out)
+ x)) #f)
+ "r")))
+ (set-port-filename! copycat filename)
+ (do ((c (read-char port) (read-char port)))
+ ((and (char=? c #\#)
+ (char=? (peek-char port) #\}))
+ ;; we stop when #} is encountered
+ (read-char port))
+ (write-char c out)
+ ;; a #scheme or $scheme expression
+ (if (or (char=? c #\#) (char=? c #\$))
+ (let* ((p (ftell out))
+ (expr
+ (begin
+ (set-port-line! copycat
+ (port-line port))
+ (set-port-column! copycat
+ (port-column port))
+ (if (char=? (peek-char port) #\@)
+ (read-char copycat))
+ (read copycat))))
+ ;; kill unused lookahead, it has been
+ ;; written out already
+ (drain-input copycat)
+ ;; only put symbols and non-quote
+ ;; lists into closures -- constants
+ ;; don't need lexical environments
+ ;; for evaluation.
+ (if (or (symbol? expr)
+ (and (pair? expr)
+ (not (eq? 'quote (car expr)))))
+ (set! closures
+ (cons `(cons ,p (lambda () ,expr))
+ closures)))))))))))
(define (embedded-lilypond parser lily-string filename line
closures location)
(let* ((clone (ly:parser-clone parser closures location))
- (result (ly:parse-string-expression clone lily-string
- filename line)))
- (if (ly:parser-has-error? clone)
- (ly:parser-error parser (_ "error in #{ ... #}")))
- result))
+ (result (ly:parse-string-expression clone lily-string
+ filename line)))
+ (if (ly:parser-has-error? clone)
+ (ly:parser-error parser (_ "error in #{ ... #}")))
+ result))
(list embedded-lilypond
'parser lily-string filename line
(cons 'list (reverse! closures))
(define-method (previous-voice-state (vs <Voice-state>))
(let ((i (slot-ref vs 'vector-index))
- (v (slot-ref vs 'state-vector)))
+ (v (slot-ref vs 'state-vector)))
(if (< 0 i)
- (vector-ref v (1- i))
- #f)))
+ (vector-ref v (1- i))
+ #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; voice-states are states starting with the Split-state or later
;;
(is #:init-keyword #:voice-states #:accessor voice-states)
- (synced #:init-keyword #:synced #:init-value #f #:getter synced?))
+ (synced #:init-keyword #:synced #:init-value #f #:getter synced?))
(define-method (write (x <Split-state> ) f)
(define (make-voice-states evl)
(let ((vec (list->vector (map (lambda (v)
- (make <Voice-state>
- #:moment (caar v)
- #:tuning (cdar v)
- #:events (map car (cdr v))))
- evl))))
+ (make <Voice-state>
+ #:moment (caar v)
+ #:tuning (cdar v)
+ #:events (map car (cdr v))))
+ evl))))
(do ((i 0 (1+ i)))
- ((= i (vector-length vec)) vec)
+ ((= i (vector-length vec)) vec)
(slot-set! (vector-ref vec i) 'vector-index i)
(slot-set! (vector-ref vec i) 'state-vector vec))))
"
(define (helper ss-idx ss-list idx1 idx2)
(let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
- (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
- (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2)))
- (state1 (moment state1))
- (state2 (moment state2))
- (else #f)))
- (inc1 (if (and state1 (equal? min (moment state1))) 1 0))
- (inc2 (if (and state2 (equal? min (moment state2))) 1 0))
- (ss-object (if min
- (make <Split-state>
- #:moment min
- #:voice-states (cons state1 state2)
- #:synced (= inc1 inc2))
- #f)))
+ (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
+ (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2)))
+ (state1 (moment state1))
+ (state2 (moment state2))
+ (else #f)))
+ (inc1 (if (and state1 (equal? min (moment state1))) 1 0))
+ (inc2 (if (and state2 (equal? min (moment state2))) 1 0))
+ (ss-object (if min
+ (make <Split-state>
+ #:moment min
+ #:voice-states (cons state1 state2)
+ #:synced (= inc1 inc2))
+ #f)))
(if state1
- (set! (split-index state1) ss-idx))
+ (set! (split-index state1) ss-idx))
(if state2
- (set! (split-index state2) ss-idx))
+ (set! (split-index state2) ss-idx))
(if min
- (helper (1+ ss-idx)
- (cons ss-object ss-list)
- (+ idx1 inc1)
- (+ idx2 inc2))
- ss-list)))
+ (helper (1+ ss-idx)
+ (cons ss-object ss-list)
+ (+ idx1 inc1)
+ (+ idx2 inc2))
+ ss-list)))
(list->vector (reverse! (helper 0 '() 0 0) '())))
(define (analyse-spanner-states voice-state-vec)
(define (analyse-tie-start active ev)
(if (ly:in-event-class? ev 'tie-event)
- (acons 'tie (split-index (vector-ref voice-state-vec index))
- active)
- active))
+ (acons 'tie (split-index (vector-ref voice-state-vec index))
+ active)
+ active))
(define (analyse-tie-end active ev)
(if (ly:in-event-class? ev 'note-event)
- (assoc-remove! active 'tie)
- active))
+ (assoc-remove! active 'tie)
+ active))
(define (analyse-absdyn-end active ev)
(if (or (ly:in-event-class? ev 'absolute-dynamic-event)
- (and (ly:in-event-class? ev 'span-dynamic-event)
- (equal? STOP (ly:event-property ev 'span-direction))))
- (assoc-remove! (assoc-remove! active 'cresc) 'decr)
- active))
+ (and (ly:in-event-class? ev 'span-dynamic-event)
+ (equal? STOP (ly:event-property ev 'span-direction))))
+ (assoc-remove! (assoc-remove! active 'cresc) 'decr)
+ active))
(define (active<? a b)
(cond ((symbol<? (car a) (car b)) #t)
- ((symbol<? (car b) (car a)) #f)
- (else (< (cdr a) (cdr b)))))
+ ((symbol<? (car b) (car a)) #f)
+ (else (< (cdr a) (cdr b)))))
(define (analyse-span-event active ev)
(let* ((name (car (ly:event-property ev 'class)))
- (key (cond ((equal? name 'slur-event) 'slur)
- ((equal? name 'phrasing-slur-event) 'tie)
- ((equal? name 'beam-event) 'beam)
- ((equal? name 'crescendo-event) 'cresc)
- ((equal? name 'decrescendo-event) 'decr)
- (else #f)))
- (sp (ly:event-property ev 'span-direction)))
- (if (and (symbol? key) (ly:dir? sp))
- (if (= sp STOP)
- (assoc-remove! active key)
- (acons key
- (split-index (vector-ref voice-state-vec index))
- active))
- active)))
+ (key (cond ((equal? name 'slur-event) 'slur)
+ ((equal? name 'phrasing-slur-event) 'tie)
+ ((equal? name 'beam-event) 'beam)
+ ((equal? name 'crescendo-event) 'cresc)
+ ((equal? name 'decrescendo-event) 'decr)
+ (else #f)))
+ (sp (ly:event-property ev 'span-direction)))
+ (if (and (symbol? key) (ly:dir? sp))
+ (if (= sp STOP)
+ (assoc-remove! active key)
+ (acons key
+ (split-index (vector-ref voice-state-vec index))
+ active))
+ active)))
(define (analyse-events active evs)
"Run all analyzers on ACTIVE and EVS"
(define (run-analyzer analyzer active evs)
- (if (pair? evs)
- (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
- active))
+ (if (pair? evs)
+ (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
+ active))
(define (run-analyzers analyzers active evs)
- (if (pair? analyzers)
- (run-analyzers (cdr analyzers)
- (run-analyzer (car analyzers) active evs)
- evs)
- active))
+ (if (pair? analyzers)
+ (run-analyzers (cdr analyzers)
+ (run-analyzer (car analyzers) active evs)
+ evs)
+ active))
(sort ;; todo: use fold or somesuch.
(run-analyzers (list analyse-absdyn-end analyse-span-event
- ;; note: tie-start/span comes after tie-end/absdyn.
- analyse-tie-end analyse-tie-start)
- active evs)
+ ;; note: tie-start/span comes after tie-end/absdyn.
+ analyse-tie-end analyse-tie-start)
+ active evs)
active<?))
;; must copy, since we use assoc-remove!
(if (< index (vector-length voice-state-vec))
- (begin
- (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
- (set! (span-state (vector-ref voice-state-vec index))
- (list-copy active))
- (helper (1+ index) active))))
+ (begin
+ (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
+ (set! (span-state (vector-ref voice-state-vec index))
+ (list-copy active))
+ (helper (1+ index) active))))
(helper 0 '()))
in a chronological list, similar to the @code{Recording_group_engraver} in
LilyPond version 2.8 and earlier."
(let*
- ((context-list '())
- (now-mom (ly:make-moment 0 0))
- (global (ly:make-global-context odef))
- (mom-listener (ly:make-listener
- (lambda (tev) (set! now-mom (ly:event-property tev 'moment)))))
- (new-context-listener
- (ly:make-listener
- (lambda (sev)
- (let*
- ((child (ly:event-property sev 'context))
- (this-moment-list (cons (ly:context-id child) '()))
- (dummy (set! context-list (cons this-moment-list context-list)))
- (acc '())
- (accumulate-event-listener
- (ly:make-listener (lambda (ev)
- (set! acc (cons (cons ev #t) acc)))))
- (save-acc-listener
- (ly:make-listener (lambda (tev)
- (if (pair? acc)
- (let ((this-moment
- (cons (cons now-mom
- (ly:context-property child 'instrumentTransposition))
- ;; The accumulate-event-listener above creates
- ;; the list of events in reverse order, so we
- ;; have to revert it to the original order again
- (reverse acc))))
- (set-cdr! this-moment-list
- (cons this-moment (cdr this-moment-list)))
- (set! acc '())))))))
- (ly:add-listener accumulate-event-listener
- (ly:context-event-source child) 'StreamEvent)
- (ly:add-listener save-acc-listener
- (ly:context-event-source global) 'OneTimeStep))))))
+ ((context-list '())
+ (now-mom (ly:make-moment 0 0))
+ (global (ly:make-global-context odef))
+ (mom-listener (ly:make-listener
+ (lambda (tev) (set! now-mom (ly:event-property tev 'moment)))))
+ (new-context-listener
+ (ly:make-listener
+ (lambda (sev)
+ (let*
+ ((child (ly:event-property sev 'context))
+ (this-moment-list (cons (ly:context-id child) '()))
+ (dummy (set! context-list (cons this-moment-list context-list)))
+ (acc '())
+ (accumulate-event-listener
+ (ly:make-listener (lambda (ev)
+ (set! acc (cons (cons ev #t) acc)))))
+ (save-acc-listener
+ (ly:make-listener (lambda (tev)
+ (if (pair? acc)
+ (let ((this-moment
+ (cons (cons now-mom
+ (ly:context-property child 'instrumentTransposition))
+ ;; The accumulate-event-listener above creates
+ ;; the list of events in reverse order, so we
+ ;; have to revert it to the original order again
+ (reverse acc))))
+ (set-cdr! this-moment-list
+ (cons this-moment (cdr this-moment-list)))
+ (set! acc '())))))))
+ (ly:add-listener accumulate-event-listener
+ (ly:context-event-source child) 'StreamEvent)
+ (ly:add-listener save-acc-listener
+ (ly:context-event-source global) 'OneTimeStep))))))
(ly:add-listener new-context-listener
- (ly:context-events-below global) 'AnnounceNewContext)
+ (ly:context-events-below global) 'AnnounceNewContext)
(ly:add-listener mom-listener (ly:context-event-source global) 'Prepare)
(ly:interpret-music-expression (make-non-relative-music music) global)
context-list))
(define-public (make-part-combine-music parser music-list direction)
(let* ((m (make-music 'PartCombineMusic))
- (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one")))
- (m2 (make-non-relative-music (context-spec-music (second music-list) 'Voice "two")))
- (listener (ly:parser-lookup parser 'partCombineListener))
- (evs2 (recording-group-emulate m2 listener))
- (evs1 (recording-group-emulate m1 listener)))
+ (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one")))
+ (m2 (make-non-relative-music (context-spec-music (second music-list) 'Voice "two")))
+ (listener (ly:parser-lookup parser 'partCombineListener))
+ (evs2 (recording-group-emulate m2 listener))
+ (evs1 (recording-group-emulate m1 listener)))
(set! (ly:music-property m 'elements) (list m1 m2))
(set! (ly:music-property m 'direction) direction)
(set! (ly:music-property m 'split-list)
- (if (and (assoc "one" evs1) (assoc "two" evs2))
- (determine-split-list (reverse! (assoc-get "one" evs1) '())
- (reverse! (assoc-get "two" evs2) '()))
- '()))
+ (if (and (assoc "one" evs1) (assoc "two" evs2))
+ (determine-split-list (reverse! (assoc-get "one" evs1) '())
+ (reverse! (assoc-get "two" evs2) '()))
+ '()))
m))
(define-public (determine-split-list evl1 evl2)
"@var{evl1} and @var{evl2} should be ascending."
(let* ((pc-debug #f)
- (chord-threshold 8)
- (voice-state-vec1 (make-voice-states evl1))
- (voice-state-vec2 (make-voice-states evl2))
- (result (make-split-state voice-state-vec1 voice-state-vec2)))
+ (chord-threshold 8)
+ (voice-state-vec1 (make-voice-states evl1))
+ (voice-state-vec2 (make-voice-states evl2))
+ (result (make-split-state voice-state-vec1 voice-state-vec2)))
;; Go through all moments recursively and check if the events of that
;; moment contain a part-combine-force-event override. If so, store its
(define (analyse-forced-combine result-idx prev-res)
(define (get-forced-event x)
- (if (ly:in-event-class? x 'part-combine-force-event)
- (cons (ly:event-property x 'forced-type) (ly:event-property x 'once))
- #f))
+ (if (ly:in-event-class? x 'part-combine-force-event)
+ (cons (ly:event-property x 'forced-type) (ly:event-property x 'once))
+ #f))
(define (part-combine-events vs)
- (if (not vs)
- '()
- (filter-map get-forced-event (events vs))))
+ (if (not vs)
+ '()
+ (filter-map get-forced-event (events vs))))
;; end part-combine-events
;; forced-result: Take the previous config and analyse whether
;; any change happened.... Return new once and permanent config
(define (forced-result evt state)
- ;; sanity check, evt should always be (new-state . once)
- (if (not (and (pair? evt) (pair? state)))
- state
- (if (cdr evt)
- ;; Once-event, leave permanent state unchanged
- (cons (car evt) (cdr state))
- ;; permanent change, leave once state unchanged
- (cons (car state) (car evt)))))
+ ;; sanity check, evt should always be (new-state . once)
+ (if (not (and (pair? evt) (pair? state)))
+ state
+ (if (cdr evt)
+ ;; Once-event, leave permanent state unchanged
+ (cons (car evt) (cdr state))
+ ;; permanent change, leave once state unchanged
+ (cons (car state) (car evt)))))
;; end forced-combine-result
;; body of analyse-forced-combine:
(if (< result-idx (vector-length result))
- (let* ((now-state (vector-ref result result-idx)) ; current result
- ;; Extract all part-combine force events
- (ev1 (part-combine-events (car (voice-states now-state))))
- (ev2 (part-combine-events (cdr (voice-states now-state))))
- (evts (append ev1 ev2))
- ;; result is (once-state permament-state):
- (state (fold forced-result (cons 'automatic prev-res) evts))
- ;; Now let once override permanent changes:
- (force-state (if (equal? (car state) 'automatic)
- (cdr state)
- (car state))))
- (set! (forced-configuration (vector-ref result result-idx))
- force-state)
- ;; For the next moment, ignore the once override (car stat)
- ;; and pass on the permanent override, stored as (cdr state)
- (analyse-forced-combine (1+ result-idx) (cdr state)))))
+ (let* ((now-state (vector-ref result result-idx)) ; current result
+ ;; Extract all part-combine force events
+ (ev1 (part-combine-events (car (voice-states now-state))))
+ (ev2 (part-combine-events (cdr (voice-states now-state))))
+ (evts (append ev1 ev2))
+ ;; result is (once-state permament-state):
+ (state (fold forced-result (cons 'automatic prev-res) evts))
+ ;; Now let once override permanent changes:
+ (force-state (if (equal? (car state) 'automatic)
+ (cdr state)
+ (car state))))
+ (set! (forced-configuration (vector-ref result result-idx))
+ force-state)
+ ;; For the next moment, ignore the once override (car stat)
+ ;; and pass on the permanent override, stored as (cdr state)
+ (analyse-forced-combine (1+ result-idx) (cdr state)))))
;; end analyse-forced-combine
(define (analyse-time-step result-idx)
(define (put x . index)
- "Put the result to X, starting from INDEX backwards.
+ "Put the result to X, starting from INDEX backwards.
Only set if not set previously.
"
- (let ((i (if (pair? index) (car index) result-idx)))
- (if (and (<= 0 i)
- (not (symbol? (configuration (vector-ref result i)))))
- (begin
- (set! (configuration (vector-ref result i)) x)
- (put x (1- i))))))
+ (let ((i (if (pair? index) (car index) result-idx)))
+ (if (and (<= 0 i)
+ (not (symbol? (configuration (vector-ref result i)))))
+ (begin
+ (set! (configuration (vector-ref result i)) x)
+ (put x (1- i))))))
(define (copy-state-from state-vec vs)
- (define (copy-one-state key-idx)
- (let* ((idx (cdr key-idx))
- (prev-ss (vector-ref result idx))
- (prev (configuration prev-ss)))
- (if (symbol? prev)
- (put prev))))
- (map copy-one-state (span-state vs)))
+ (define (copy-one-state key-idx)
+ (let* ((idx (cdr key-idx))
+ (prev-ss (vector-ref result idx))
+ (prev (configuration prev-ss)))
+ (if (symbol? prev)
+ (put prev))))
+ (map copy-one-state (span-state vs)))
(define (analyse-notes now-state)
- (let* ((vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state)))
- (notes1 (note-events vs1))
- (durs1 (sort (map (lambda (x) (ly:event-property x 'duration))
- notes1)
- ly:duration<?))
- (pitches1 (sort (map (lambda (x) (ly:event-property x 'pitch))
- notes1)
- ly:pitch<?))
- (notes2 (note-events vs2))
- (durs2 (sort (map (lambda (x) (ly:event-property x 'duration))
- notes2)
- ly:duration<?))
- (pitches2 (sort (map (lambda (x) (ly:event-property x 'pitch))
- notes2)
- ly:pitch<?)))
- (cond ((> (length notes1) 1) (put 'apart))
- ((> (length notes2) 1) (put 'apart))
- ((= 1 (+ (length notes2) (length notes1))) (put 'apart))
- ((and (= (length durs1) 1)
- (= (length durs2) 1)
- (not (equal? (car durs1) (car durs2))))
- (put 'apart))
- (else
- (if (and (= (length pitches1) (length pitches2)))
- (if (and (pair? pitches1)
- (pair? pitches2)
- (or
- (< chord-threshold (ly:pitch-steps
- (ly:pitch-diff (car pitches1)
- (car pitches2))))
-
- ;; voice crossings:
- (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1)
- (car pitches2))))
- ))
- (put 'apart)
- ;; copy previous split state from spanner state
- (begin
- (if (previous-voice-state vs1)
- (copy-state-from voice-state-vec1
- (previous-voice-state vs1)))
- (if (previous-voice-state vs2)
- (copy-state-from voice-state-vec2
- (previous-voice-state vs2)))
- (if (and (null? (span-state vs1)) (null? (span-state vs2)))
- (put 'chords)))))))))
+ (let* ((vs1 (car (voice-states now-state)))
+ (vs2 (cdr (voice-states now-state)))
+ (notes1 (note-events vs1))
+ (durs1 (sort (map (lambda (x) (ly:event-property x 'duration))
+ notes1)
+ ly:duration<?))
+ (pitches1 (sort (map (lambda (x) (ly:event-property x 'pitch))
+ notes1)
+ ly:pitch<?))
+ (notes2 (note-events vs2))
+ (durs2 (sort (map (lambda (x) (ly:event-property x 'duration))
+ notes2)
+ ly:duration<?))
+ (pitches2 (sort (map (lambda (x) (ly:event-property x 'pitch))
+ notes2)
+ ly:pitch<?)))
+ (cond ((> (length notes1) 1) (put 'apart))
+ ((> (length notes2) 1) (put 'apart))
+ ((= 1 (+ (length notes2) (length notes1))) (put 'apart))
+ ((and (= (length durs1) 1)
+ (= (length durs2) 1)
+ (not (equal? (car durs1) (car durs2))))
+ (put 'apart))
+ (else
+ (if (and (= (length pitches1) (length pitches2)))
+ (if (and (pair? pitches1)
+ (pair? pitches2)
+ (or
+ (< chord-threshold (ly:pitch-steps
+ (ly:pitch-diff (car pitches1)
+ (car pitches2))))
+
+ ;; voice crossings:
+ (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1)
+ (car pitches2))))
+ ))
+ (put 'apart)
+ ;; copy previous split state from spanner state
+ (begin
+ (if (previous-voice-state vs1)
+ (copy-state-from voice-state-vec1
+ (previous-voice-state vs1)))
+ (if (previous-voice-state vs2)
+ (copy-state-from voice-state-vec2
+ (previous-voice-state vs2)))
+ (if (and (null? (span-state vs1)) (null? (span-state vs2)))
+ (put 'chords)))))))))
(if (< result-idx (vector-length result))
- (let* ((now-state (vector-ref result result-idx))
- (vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state))))
-
- (cond ((not vs1) (put 'apart))
- ((not vs2) (put 'apart))
- (else
- (let ((active1 (previous-span-state vs1))
- (active2 (previous-span-state vs2))
- (new-active1 (span-state vs1))
- (new-active2 (span-state vs2)))
- (if #f ; debug
- (display (list (moment now-state) result-idx
- active1 "->" new-active1
- active2 "->" new-active2
- "\n")))
- (if (and (synced? now-state)
- (equal? active1 active2)
- (equal? new-active1 new-active2))
- (analyse-notes now-state)
-
- ;; active states different:
- (put 'apart)))
-
- ;; go to the next one, if it exists.
- (analyse-time-step (1+ result-idx)))))))
+ (let* ((now-state (vector-ref result result-idx))
+ (vs1 (car (voice-states now-state)))
+ (vs2 (cdr (voice-states now-state))))
+
+ (cond ((not vs1) (put 'apart))
+ ((not vs2) (put 'apart))
+ (else
+ (let ((active1 (previous-span-state vs1))
+ (active2 (previous-span-state vs2))
+ (new-active1 (span-state vs1))
+ (new-active2 (span-state vs2)))
+ (if #f ; debug
+ (display (list (moment now-state) result-idx
+ active1 "->" new-active1
+ active2 "->" new-active2
+ "\n")))
+ (if (and (synced? now-state)
+ (equal? active1 active2)
+ (equal? new-active1 new-active2))
+ (analyse-notes now-state)
+
+ ;; active states different:
+ (put 'apart)))
+
+ ;; go to the next one, if it exists.
+ (analyse-time-step (1+ result-idx)))))))
(define (analyse-a2 result-idx)
(if (< result-idx (vector-length result))
- (let* ((now-state (vector-ref result result-idx))
- (vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state))))
- (if (and (equal? (configuration now-state) 'chords)
- vs1 vs2)
- (let ((notes1 (note-events vs1))
- (notes2 (note-events vs2)))
- (cond ((and (= 1 (length notes1))
- (= 1 (length notes2))
- (equal? (ly:event-property (car notes1) 'pitch)
- (ly:event-property (car notes2) 'pitch)))
- (set! (configuration now-state) 'unisono))
- ((and (= 0 (length notes1))
- (= 0 (length notes2)))
- (set! (configuration now-state) 'unisilence)))))
- (analyse-a2 (1+ result-idx)))))
+ (let* ((now-state (vector-ref result result-idx))
+ (vs1 (car (voice-states now-state)))
+ (vs2 (cdr (voice-states now-state))))
+ (if (and (equal? (configuration now-state) 'chords)
+ vs1 vs2)
+ (let ((notes1 (note-events vs1))
+ (notes2 (note-events vs2)))
+ (cond ((and (= 1 (length notes1))
+ (= 1 (length notes2))
+ (equal? (ly:event-property (car notes1) 'pitch)
+ (ly:event-property (car notes2) 'pitch)))
+ (set! (configuration now-state) 'unisono))
+ ((and (= 0 (length notes1))
+ (= 0 (length notes2)))
+ (set! (configuration now-state) 'unisilence)))))
+ (analyse-a2 (1+ result-idx)))))
(define (analyse-solo12 result-idx)
(define (previous-config vs)
- (let* ((pvs (previous-voice-state vs))
- (spi (if pvs (split-index pvs) #f))
- (prev-split (if spi (vector-ref result spi) #f)))
- (if prev-split
- (configuration prev-split)
- 'apart)))
+ (let* ((pvs (previous-voice-state vs))
+ (spi (if pvs (split-index pvs) #f))
+ (prev-split (if spi (vector-ref result spi) #f)))
+ (if prev-split
+ (configuration prev-split)
+ 'apart)))
(define (put-range x a b)
- ;; (display (list "put range " x a b "\n"))
- (do ((i a (1+ i)))
- ((> i b) b)
- (set! (configuration (vector-ref result i)) x)))
+ ;; (display (list "put range " x a b "\n"))
+ (do ((i a (1+ i)))
+ ((> i b) b)
+ (set! (configuration (vector-ref result i)) x)))
(define (put x)
- ;; (display (list "putting " x "\n"))
- (set! (configuration (vector-ref result result-idx)) x))
+ ;; (display (list "putting " x "\n"))
+ (set! (configuration (vector-ref result result-idx)) x))
(define (current-voice-state now-state voice-num)
- (define vs ((if (= 1 voice-num) car cdr)
- (voice-states now-state)))
- (if (or (not vs) (equal? (moment now-state) (moment vs)))
- vs
- (previous-voice-state vs)))
+ (define vs ((if (= 1 voice-num) car cdr)
+ (voice-states now-state)))
+ (if (or (not vs) (equal? (moment now-state) (moment vs)))
+ vs
+ (previous-voice-state vs)))
(define (try-solo type start-idx current-idx)
- "Find a maximum stretch that can be marked as solo. Only set
+ "Find a maximum stretch that can be marked as solo. Only set
the mark when there are no spanners active.
return next idx to analyse.
"
- (if (< current-idx (vector-length result))
- (let* ((now-state (vector-ref result current-idx))
- (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
- (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
- (silent-notes (if silent-state (note-events silent-state) '()))
- (solo-notes (if solo-state (note-events solo-state) '())))
- ;; (display (list "trying " type " at " (moment now-state) solo-state silent-state "\n"))
- (cond ((not (equal? (configuration now-state) 'apart))
- current-idx)
- ((> (length silent-notes) 0) start-idx)
- ((not solo-state)
- (put-range type start-idx current-idx)
- current-idx)
- ((and
- (null? (span-state solo-state)))
-
- ;;
- ;; This includes rests. This isn't a problem: long rests
- ;; will be shared with the silent voice, and be marked
- ;; as unisilence. Therefore, long rests won't
- ;; accidentally be part of a solo.
- ;;
- (put-range type start-idx current-idx)
- (try-solo type (1+ current-idx) (1+ current-idx)))
- (else
- (try-solo type start-idx (1+ current-idx)))))
- ;; try-solo
- start-idx))
+ (if (< current-idx (vector-length result))
+ (let* ((now-state (vector-ref result current-idx))
+ (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
+ (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
+ (silent-notes (if silent-state (note-events silent-state) '()))
+ (solo-notes (if solo-state (note-events solo-state) '())))
+ ;; (display (list "trying " type " at " (moment now-state) solo-state silent-state "\n"))
+ (cond ((not (equal? (configuration now-state) 'apart))
+ current-idx)
+ ((> (length silent-notes) 0) start-idx)
+ ((not solo-state)
+ (put-range type start-idx current-idx)
+ current-idx)
+ ((and
+ (null? (span-state solo-state)))
+
+ ;;
+ ;; This includes rests. This isn't a problem: long rests
+ ;; will be shared with the silent voice, and be marked
+ ;; as unisilence. Therefore, long rests won't
+ ;; accidentally be part of a solo.
+ ;;
+ (put-range type start-idx current-idx)
+ (try-solo type (1+ current-idx) (1+ current-idx)))
+ (else
+ (try-solo type start-idx (1+ current-idx)))))
+ ;; try-solo
+ start-idx))
(define (analyse-moment result-idx)
- "Analyse 'apart starting at RESULT-IDX. Return next index."
- (let* ((now-state (vector-ref result result-idx))
- (vs1 (current-voice-state now-state 1))
- (vs2 (current-voice-state now-state 2))
- ;; (vs1 (car (voice-states now-state)))
- ;; (vs2 (cdr (voice-states now-state)))
- (notes1 (if vs1 (note-events vs1) '()))
- (notes2 (if vs2 (note-events vs2) '()))
- (n1 (length notes1))
- (n2 (length notes2)))
- ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n"))
- (max
- ;; we should always increase.
- (cond ((and (= n1 0) (= n2 0))
- (put 'apart-silence)
- (1+ result-idx))
- ((and (= n2 0)
- (equal? (moment vs1) (moment now-state))
- (null? (previous-span-state vs1)))
- (try-solo 'solo1 result-idx result-idx))
- ((and (= n1 0)
- (equal? (moment vs2) (moment now-state))
- (null? (previous-span-state vs2)))
- (try-solo 'solo2 result-idx result-idx))
-
- (else (1+ result-idx)))
- ;; analyse-moment
- (1+ result-idx))))
+ "Analyse 'apart starting at RESULT-IDX. Return next index."
+ (let* ((now-state (vector-ref result result-idx))
+ (vs1 (current-voice-state now-state 1))
+ (vs2 (current-voice-state now-state 2))
+ ;; (vs1 (car (voice-states now-state)))
+ ;; (vs2 (cdr (voice-states now-state)))
+ (notes1 (if vs1 (note-events vs1) '()))
+ (notes2 (if vs2 (note-events vs2) '()))
+ (n1 (length notes1))
+ (n2 (length notes2)))
+ ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n"))
+ (max
+ ;; we should always increase.
+ (cond ((and (= n1 0) (= n2 0))
+ (put 'apart-silence)
+ (1+ result-idx))
+ ((and (= n2 0)
+ (equal? (moment vs1) (moment now-state))
+ (null? (previous-span-state vs1)))
+ (try-solo 'solo1 result-idx result-idx))
+ ((and (= n1 0)
+ (equal? (moment vs2) (moment now-state))
+ (null? (previous-span-state vs2)))
+ (try-solo 'solo2 result-idx result-idx))
+
+ (else (1+ result-idx)))
+ ;; analyse-moment
+ (1+ result-idx))))
(if (< result-idx (vector-length result))
- (if (equal? (configuration (vector-ref result result-idx)) 'apart)
- (analyse-solo12 (analyse-moment result-idx))
- (analyse-solo12 (1+ result-idx))))) ; analyse-solo12
+ (if (equal? (configuration (vector-ref result result-idx)) 'apart)
+ (analyse-solo12 (analyse-moment result-idx))
+ (analyse-solo12 (1+ result-idx))))) ; analyse-solo12
(analyse-spanner-states voice-state-vec1)
(analyse-spanner-states voice-state-vec2)
(if #f
- (begin
- (display voice-state-vec1)
- (display "***\n")
- (display voice-state-vec2)
- (display "***\n")
- (display result)
- (display "***\n")))
+ (begin
+ (display voice-state-vec1)
+ (display "***\n")
+ (display voice-state-vec2)
+ (display "***\n")
+ (display result)
+ (display "***\n")))
;; Extract all forced combine strategies, i.e. events inserted by
;; \partcombine(Apart|Automatic|SoloI|SoloII|Chords)[Once]
(analyse-solo12 0)
;; (display result)
(set! result (map
- ;; forced-configuration overrides, if it is set
- (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x))))
- (vector->list result)))
+ ;; forced-configuration overrides, if it is set
+ (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x))))
+ (vector->list result)))
(if #f ;; pc-debug
- (display result))
+ (display result))
result))
(define-public (parse-terse-string terse-definition)
"Parse a @code{fret-diagram-terse} definition string @var{terse-definition}
and return a marking list, which can be used with a fretboard grob."
- (cdr (fret-parse-terse-definition-string (list '()) terse-definition)))
+ (cdr (fret-parse-terse-definition-string (list '()) terse-definition)))
(define-public (get-chord-shape shape-code tuning base-chord-shapes)
"Return the chord shape associated with @var{shape-code} and
@var{tuning} in the hash-table @var{base-chord-shapes}."
(let ((hash-handle (hash-get-handle base-chord-shapes
- (cons shape-code tuning))))
- (if hash-handle
- (cdr hash-handle)
- '())))
+ (cons shape-code tuning))))
+ (if hash-handle
+ (cdr hash-handle)
+ '())))
(define-public (offset-fret fret-offset diagram-definition)
"Add @var{fret-offset} to each fret indication in
@var{diagram-definition} and return the resulting verbose
@code{fret-diagram-definition}."
- (let ((verbose-definition
- (if (string? diagram-definition)
- (parse-terse-string diagram-definition)
- diagram-definition)))
- (map (lambda(item)
- (let ((code (car item)))
- (cond
- ((eq? code 'barre)
- (list-set! item 3
- (+ fret-offset (list-ref item 3)))
- item)
- ((eq? code 'capo)
- (list-set! item 1
- (+ fret-offset (list-ref item 1)))
- item)
- ((eq? code 'place-fret)
- (list-set! item 2
- (+ fret-offset (list-ref item 2)))
- item)
- (else item))))
- verbose-definition)))
-
+ (let ((verbose-definition
+ (if (string? diagram-definition)
+ (parse-terse-string diagram-definition)
+ diagram-definition)))
+ (map (lambda(item)
+ (let ((code (car item)))
+ (cond
+ ((eq? code 'barre)
+ (list-set! item 3
+ (+ fret-offset (list-ref item 3)))
+ item)
+ ((eq? code 'capo)
+ (list-set! item 1
+ (+ fret-offset (list-ref item 1)))
+ item)
+ ((eq? code 'place-fret)
+ (list-set! item 2
+ (+ fret-offset (list-ref item 2)))
+ item)
+ (else item))))
+ verbose-definition)))
(define (search-executable names)
(define (helper path lst)
(if (null? (cdr lst))
- (car lst)
- (if (search-path path (car lst)) (car lst)
- (helper path (cdr lst)))))
+ (car lst)
+ (if (search-path path (car lst)) (car lst)
+ (helper path (cdr lst)))))
(let ((path (parse-path (getenv "PATH"))))
(helper path names)))
(set! status (system cmd))
(if (not (= status 0))
(begin
- (ly:error (_ "~a exited with status: ~S") "GS" status)
- (if exit-on-error (exit 1))))
+ (ly:error (_ "~a exited with status: ~S") "GS" status)
+ (if exit-on-error (exit 1))))
status)
(define (scale-down-image be-verbose factor file)
(define (with-pbm)
(let* ((status 0)
- (old (string-append file ".old")))
-
+ (old (string-append file ".old")))
+
(rename-file file old)
(my-system
be-verbose #t
(format #f
- "pngtopnm \"~a\" | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > \"~a\""
- old factor file))
+ "pngtopnm \"~a\" | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > \"~a\""
+ old factor file))
(delete-file old)))
(with-pbm))
(define-public (ps-page-count ps-name)
(let* ((byte-count 10240)
- (header (gulp-file ps-name byte-count))
- (first-null (string-index header #\nul))
- (match (string-match "%%Pages: ([0-9]+)"
- (if (number? first-null)
- (substring header 0 first-null)
- header))))
+ (header (gulp-file ps-name byte-count))
+ (first-null (string-index header #\nul))
+ (match (string-match "%%Pages: ([0-9]+)"
+ (if (number? first-null)
+ (substring header 0 first-null)
+ header))))
(if match (string->number (match:substring match 1)) 0)))
(define-public (make-ps-images ps-name . rest)
(anti-alias-factor 1))
(let* ((format-str (format #f "~a" pixmap-format))
- (extension (cond
- ((string-contains format-str "png") "png")
- ((string-contains format-str "jpg") "jpeg")
- ((string-contains format-str "jpeg") "jpeg")
- (else
- (ly:error "Unknown pixmap format ~a" pixmap-format))))
- (base (dir-basename ps-name ".ps" ".eps"))
- (png1 (format #f "~a.~a" base extension))
- (pngn (format #f "~a-page%d.~a" base extension))
- (page-count (ps-page-count ps-name))
- (multi-page? (> page-count 1))
- (output-file (if multi-page? pngn png1))
-
- (gs-variable-options
- (if (string-suffix-ci? ".eps" ps-name)
- "-dEPSCrop"
- (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f"
- page-width page-height)))
- (cmd (ly:format "~a\
+ (extension (cond
+ ((string-contains format-str "png") "png")
+ ((string-contains format-str "jpg") "jpeg")
+ ((string-contains format-str "jpeg") "jpeg")
+ (else
+ (ly:error "Unknown pixmap format ~a" pixmap-format))))
+ (base (dir-basename ps-name ".ps" ".eps"))
+ (png1 (format #f "~a.~a" base extension))
+ (pngn (format #f "~a-page%d.~a" base extension))
+ (page-count (ps-page-count ps-name))
+ (multi-page? (> page-count 1))
+ (output-file (if multi-page? pngn png1))
+
+ (gs-variable-options
+ (if (string-suffix-ci? ".eps" ps-name)
+ "-dEPSCrop"
+ (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f"
+ page-width page-height)))
+ (cmd (ly:format "~a\
~a\
~a\
-dGraphicsAlphaBits=4\
-r~a\
~S\
-c quit"
- (search-gs)
- (if be-verbose "" "-q")
- gs-variable-options
- pixmap-format
- output-file
- (* anti-alias-factor resolution) ps-name))
- (status 0)
- (files '()))
+ (search-gs)
+ (if be-verbose "" "-q")
+ gs-variable-options
+ pixmap-format
+ output-file
+ (* anti-alias-factor resolution) ps-name))
+ (status 0)
+ (files '()))
;; The wrapper on windows cannot handle `=' signs,
;; gs has a workaround with #.
(if (eq? PLATFORM 'windows)
- (begin
- (set! cmd (re-sub "=" "#" cmd))
- (set! cmd (re-sub "-dSAFER " "" cmd))))
+ (begin
+ (set! cmd (re-sub "=" "#" cmd))
+ (set! cmd (re-sub "-dSAFER " "" cmd))))
(set! status (my-system be-verbose #f cmd))
(set! files
- (if multi-page?
- (map
- (lambda (n)
- (format #f "~a-page~a.png" base (1+ n)))
- (iota page-count))
- (list (format #f "~a.png" base))))
-
+ (if multi-page?
+ (map
+ (lambda (n)
+ (format #f "~a-page~a.png" base (1+ n)))
+ (iota page-count))
+ (list (format #f "~a.png" base))))
+
(if (not (= 0 status))
- (begin
- (map delete-file files)
- (exit 1)))
+ (begin
+ (map delete-file files)
+ (exit 1)))
(if (and rename-page-1 multi-page?)
- (begin
- (rename-file (re-sub "%d" "1" pngn) png1)
- (set! files
- (cons png1
- (cdr files)))
- ))
+ (begin
+ (rename-file (re-sub "%d" "1" pngn) png1)
+ (set! files
+ (cons png1
+ (cdr files)))
+ ))
(if (not (= 1 anti-alias-factor))
- (for-each
- (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files))
+ (for-each
+ (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files))
files)))
;;; Author Ian Hulin
;;; Date 16 October 2011
;;;
-
+
(define-module (scm safe-utility-defs)
-#:use-module (ice-9 optargs)
-#:export (safe-objects)
-#:export-syntax (define-safe-public)
-#:re-export-syntax (define*-public))
+ #:use-module (ice-9 optargs)
+ #:export (safe-objects)
+ #:export-syntax (define-safe-public)
+ #:re-export-syntax (define*-public))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Safe definitions utility
(elapsed 0))
(make-engraver
- (listeners ((measure-counter-event engraver event)
- (set! last-measure-seen (ly:context-property context 'currentBarNumber))
- (set! new-measure? #t)
- (cond
- ((and (= START (ly:event-property event 'span-direction))
- go?)
- (begin
- (set! stop? #t)
- (ly:input-warning
- (ly:event-property event 'origin)
- "count not ended before another begun")))
- ((= START (ly:event-property event 'span-direction))
- (set! go? #t))
- ((= STOP (ly:event-property event 'span-direction))
- (begin
- (set! stop? #t)
- (set! go? #f))))))
+ (listeners ((measure-counter-event engraver event)
+ (set! last-measure-seen (ly:context-property context 'currentBarNumber))
+ (set! new-measure? #t)
+ (cond
+ ((and (= START (ly:event-property event 'span-direction))
+ go?)
+ (begin
+ (set! stop? #t)
+ (ly:input-warning
+ (ly:event-property event 'origin)
+ "count not ended before another begun")))
+ ((= START (ly:event-property event 'span-direction))
+ (set! go? #t))
+ ((= STOP (ly:event-property event 'span-direction))
+ (begin
+ (set! stop? #t)
+ (set! go? #f))))))
- ((process-music trans)
- (let ((col (ly:context-property context 'currentCommandColumn))
- (now (ly:context-property context 'measurePosition))
- (current-bar (ly:context-property context 'currentBarNumber)))
- ;; If the counter has been started, make sure we're in a new bar
- ;; before finishing a count-spanner and starting a new one.
- ;; Since we consider all CommandColumns encountered, we need this
- ;; check so that a count-spanner is not created for each pair.
- (if (and (ly:grob? count-spanner)
- (> current-bar last-measure-seen))
- (set! new-measure? #t))
- (if new-measure?
- (begin
- ;; Check if we have the first column of the measure.
- ;; The possibility of initial grace notes is considered.
- (if (moment<=? now ZERO-MOMENT)
- (begin
- ;; If we have the first column, finish the previous
- ;; counter-spanner (if there is one).
- (if (ly:grob? count-spanner)
- (begin
- (ly:spanner-set-bound! count-spanner RIGHT col)
- (ly:pointer-group-interface::add-grob count-spanner 'columns col)
- (ly:engraver-announce-end-grob trans count-spanner col)
- (set! count-spanner '())))
- ;; if count is over, reset variables
- (if stop?
- (begin
- (set! elapsed 0)
- (set! stop? #f)))
- ;; if count is in progress, begin a counter object
- (if go?
- (let* ((c (ly:engraver-make-grob trans 'MeasureCounter col))
- (counter (ly:grob-property c 'count-from)))
- (ly:spanner-set-bound! c LEFT col)
- (ly:pointer-group-interface::add-grob c 'columns col)
- (set! (ly:grob-property c 'count-from) (+ counter elapsed))
- (set! count-spanner c)
- (set! elapsed (1+ elapsed))))
- (set! new-measure? #f)))))
- (set! last-measure-seen current-bar)))
+ ((process-music trans)
+ (let ((col (ly:context-property context 'currentCommandColumn))
+ (now (ly:context-property context 'measurePosition))
+ (current-bar (ly:context-property context 'currentBarNumber)))
+ ;; If the counter has been started, make sure we're in a new bar
+ ;; before finishing a count-spanner and starting a new one.
+ ;; Since we consider all CommandColumns encountered, we need this
+ ;; check so that a count-spanner is not created for each pair.
+ (if (and (ly:grob? count-spanner)
+ (> current-bar last-measure-seen))
+ (set! new-measure? #t))
+ (if new-measure?
+ (begin
+ ;; Check if we have the first column of the measure.
+ ;; The possibility of initial grace notes is considered.
+ (if (moment<=? now ZERO-MOMENT)
+ (begin
+ ;; If we have the first column, finish the previous
+ ;; counter-spanner (if there is one).
+ (if (ly:grob? count-spanner)
+ (begin
+ (ly:spanner-set-bound! count-spanner RIGHT col)
+ (ly:pointer-group-interface::add-grob count-spanner 'columns col)
+ (ly:engraver-announce-end-grob trans count-spanner col)
+ (set! count-spanner '())))
+ ;; if count is over, reset variables
+ (if stop?
+ (begin
+ (set! elapsed 0)
+ (set! stop? #f)))
+ ;; if count is in progress, begin a counter object
+ (if go?
+ (let* ((c (ly:engraver-make-grob trans 'MeasureCounter col))
+ (counter (ly:grob-property c 'count-from)))
+ (ly:spanner-set-bound! c LEFT col)
+ (ly:pointer-group-interface::add-grob c 'columns col)
+ (set! (ly:grob-property c 'count-from) (+ counter elapsed))
+ (set! count-spanner c)
+ (set! elapsed (1+ elapsed))))
+ (set! new-measure? #f)))))
+ (set! last-measure-seen current-bar)))
- ((finalize trans)
- (if go?
- (begin
- (set! go? #f)
- (ly:grob-suicide! count-spanner)
- (set! count-spanner '())
- (ly:warning "measure count left unfinished")))))))
+ ((finalize trans)
+ (if go?
+ (begin
+ (set! go? #f)
+ (ly:grob-suicide! count-spanner)
+ (set! count-spanner '())
+ (ly:warning "measure count left unfinished")))))))
`(
("accent"
. (
- (avoid-slur . around)
- (padding . 0.20)
- (script-stencil . (feta . ("sforzato" . "sforzato")))
- (side-relative-direction . ,DOWN)))
+ (avoid-slur . around)
+ (padding . 0.20)
+ (script-stencil . (feta . ("sforzato" . "sforzato")))
+ (side-relative-direction . ,DOWN)))
("accentus"
. (
- (script-stencil . (feta . ("uaccentus" . "uaccentus")))
- (side-relative-direction . ,DOWN)
- (avoid-slur . ignore)
- (padding . 0.20)
- (quantize-position . #t)
- (script-priority . -100)
- (direction . ,UP)))
+ (script-stencil . (feta . ("uaccentus" . "uaccentus")))
+ (side-relative-direction . ,DOWN)
+ (avoid-slur . ignore)
+ (padding . 0.20)
+ (quantize-position . #t)
+ (script-priority . -100)
+ (direction . ,UP)))
("circulus"
. (
- (script-stencil . (feta . ("circulus" . "circulus")))
- (side-relative-direction . ,DOWN)
- (avoid-slur . ignore)
- (padding . 0.20)
- (quantize-position . #t)
- (script-priority . -100)
- (direction . ,UP)))
+ (script-stencil . (feta . ("circulus" . "circulus")))
+ (side-relative-direction . ,DOWN)
+ (avoid-slur . ignore)
+ (padding . 0.20)
+ (quantize-position . #t)
+ (script-priority . -100)
+ (direction . ,UP)))
("coda"
. (
- (script-stencil . (feta . ("coda" . "coda")))
- (padding . 0.20)
- (avoid-slur . outside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("coda" . "coda")))
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (direction . ,UP)))
("comma"
. (
- (script-stencil . (feta . ("lcomma" . "rcomma")))
- (quantize-position . #t)
- (padding . 0.20)
- (avoid-slur . ignore)
- (direction . ,UP)))
+ (script-stencil . (feta . ("lcomma" . "rcomma")))
+ (quantize-position . #t)
+ (padding . 0.20)
+ (avoid-slur . ignore)
+ (direction . ,UP)))
("downbow"
. (
- (script-stencil . (feta . ("downbow" . "downbow")))
- (padding . 0.20)
- (skyline-horizontal-padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)
- (script-priority . 150)))
+ (script-stencil . (feta . ("downbow" . "downbow")))
+ (padding . 0.20)
+ (skyline-horizontal-padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)
+ (script-priority . 150)))
("downmordent"
. (
- (script-stencil . (feta . ("downmordent" . "downmordent")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("downmordent" . "downmordent")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("downprall"
. (
- (script-stencil . (feta . ("downprall" . "downprall")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("downprall" . "downprall")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("espressivo"
. (
- (avoid-slur . around)
- (padding . 0.20)
- (script-stencil . (feta . ("espr" . "espr")))
- (side-relative-direction . ,DOWN)))
+ (avoid-slur . around)
+ (padding . 0.20)
+ (script-stencil . (feta . ("espr" . "espr")))
+ (side-relative-direction . ,DOWN)))
("fermata"
. (
- (script-stencil . (feta . ("dfermata" . "ufermata")))
- (padding . 0.20)
- (avoid-slur . around)
- (script-priority . 4000)
- (direction . ,UP)))
+ (script-stencil . (feta . ("dfermata" . "ufermata")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (script-priority . 4000)
+ (direction . ,UP)))
("flageolet"
. (
- (script-stencil . (feta . ("flageolet" . "flageolet")))
- (padding . 0.20)
- (avoid-slur . around) ;guessing?
- (direction . ,UP)))
+ (script-stencil . (feta . ("flageolet" . "flageolet")))
+ (padding . 0.20)
+ (avoid-slur . around) ;guessing?
+ (direction . ,UP)))
("halfopen"
. (
- (avoid-slur . outside)
- (padding . 0.20)
- (script-stencil . (feta . ("halfopen" . "halfopen")))
- (direction . ,UP)))
+ (avoid-slur . outside)
+ (padding . 0.20)
+ (script-stencil . (feta . ("halfopen" . "halfopen")))
+ (direction . ,UP)))
("ictus"
. (
- (script-stencil . (feta . ("ictus" . "ictus")))
- (side-relative-direction . ,DOWN)
- (quantize-position . #t)
- (avoid-slur . ignore)
- (padding . 0.20)
- (script-priority . -100)
- (direction . ,DOWN)))
+ (script-stencil . (feta . ("ictus" . "ictus")))
+ (side-relative-direction . ,DOWN)
+ (quantize-position . #t)
+ (avoid-slur . ignore)
+ (padding . 0.20)
+ (script-priority . -100)
+ (direction . ,DOWN)))
("lheel"
. (
- (script-stencil . (feta . ("upedalheel" . "upedalheel")))
- (padding . 0.20)
- (avoid-slur . around) ;guessing?
- (direction . ,DOWN)))
+ (script-stencil . (feta . ("upedalheel" . "upedalheel")))
+ (padding . 0.20)
+ (avoid-slur . around) ;guessing?
+ (direction . ,DOWN)))
("lineprall"
. (
- (script-stencil . (feta . ("lineprall" . "lineprall")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("lineprall" . "lineprall")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("longfermata"
. (
- (script-stencil . (feta . ("dlongfermata" . "ulongfermata")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("dlongfermata" . "ulongfermata")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("ltoe"
. (
- (script-stencil . (feta . ("upedaltoe" . "upedaltoe")))
- (padding . 0.20)
- (avoid-slur . around) ;guessing?
- (direction . ,DOWN)))
+ (script-stencil . (feta . ("upedaltoe" . "upedaltoe")))
+ (padding . 0.20)
+ (avoid-slur . around) ;guessing?
+ (direction . ,DOWN)))
("marcato"
. (
- (script-stencil . (feta . ("dmarcato" . "umarcato")))
- (padding . 0.20)
- (avoid-slur . inside)
+ (script-stencil . (feta . ("dmarcato" . "umarcato")))
+ (padding . 0.20)
+ (avoid-slur . inside)
;;(staff-padding . ())
- (quantize-position . #t)
- (side-relative-direction . ,DOWN)))
+ (quantize-position . #t)
+ (side-relative-direction . ,DOWN)))
("mordent"
. (
- (script-stencil . (feta . ("mordent" . "mordent")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("mordent" . "mordent")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("open"
. (
- (avoid-slur . outside)
- (padding . 0.20)
- (script-stencil . (feta . ("open" . "open")))
- (direction . ,UP)))
+ (avoid-slur . outside)
+ (padding . 0.20)
+ (script-stencil . (feta . ("open" . "open")))
+ (direction . ,UP)))
("portato"
. (
- (script-stencil . (feta . ("uportato" . "dportato")))
- (avoid-slur . around)
- (padding . 0.45)
- (side-relative-direction . ,DOWN)))
+ (script-stencil . (feta . ("uportato" . "dportato")))
+ (avoid-slur . around)
+ (padding . 0.45)
+ (side-relative-direction . ,DOWN)))
("prall"
. (
- (script-stencil . (feta . ("prall" . "prall")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("prall" . "prall")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("pralldown"
. (
- (script-stencil . (feta . ("pralldown" . "pralldown")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("pralldown" . "pralldown")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("prallmordent"
. (
- (script-stencil . (feta . ("prallmordent" . "prallmordent")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("prallmordent" . "prallmordent")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("prallprall"
. (
- (script-stencil . (feta . ("prallprall" . "prallprall")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("prallprall" . "prallprall")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("prallup"
. (
- (script-stencil . (feta . ("prallup" . "prallup")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("prallup" . "prallup")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("reverseturn"
. (
- (script-stencil . (feta . ("reverseturn" . "reverseturn")))
- (padding . 0.20)
- (avoid-slur . inside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("reverseturn" . "reverseturn")))
+ (padding . 0.20)
+ (avoid-slur . inside)
+ (direction . ,UP)))
("rheel"
. (
- (script-stencil . (feta . ("dpedalheel" . "dpedalheel")))
- (padding . 0.20)
- (avoid-slur . around) ;guessing?
- (direction . ,UP)))
+ (script-stencil . (feta . ("dpedalheel" . "dpedalheel")))
+ (padding . 0.20)
+ (avoid-slur . around) ;guessing?
+ (direction . ,UP)))
("rtoe"
. (
- (script-stencil . (feta . ("dpedaltoe" . "dpedaltoe")))
- (padding . 0.20)
- (avoid-slur . around) ;guessing?
- (direction . ,UP)))
+ (script-stencil . (feta . ("dpedaltoe" . "dpedaltoe")))
+ (padding . 0.20)
+ (avoid-slur . around) ;guessing?
+ (direction . ,UP)))
("segno"
. (
- (script-stencil . (feta . ("segno" . "segno")))
- (padding . 0.20)
- (avoid-slur . outside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("segno" . "segno")))
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (direction . ,UP)))
("semicirculus"
. (
- (script-stencil . (feta . ("dsemicirculus" . "dsemicirculus")))
- (side-relative-direction . ,DOWN)
- (quantize-position . #t)
- (avoid-slur . ignore)
- (padding . 0.20)
- (script-priority . -100)
- (direction . ,UP)))
+ (script-stencil . (feta . ("dsemicirculus" . "dsemicirculus")))
+ (side-relative-direction . ,DOWN)
+ (quantize-position . #t)
+ (avoid-slur . ignore)
+ (padding . 0.20)
+ (script-priority . -100)
+ (direction . ,UP)))
("shortfermata"
. (
- (script-stencil . (feta . ("dshortfermata" . "ushortfermata")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("dshortfermata" . "ushortfermata")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("signumcongruentiae"
. (
- (script-stencil . (feta . ("dsignumcongruentiae" . "usignumcongruentiae")))
- (padding . 0.20)
- (avoid-slur . outside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("dsignumcongruentiae" . "usignumcongruentiae")))
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (direction . ,UP)))
("snappizzicato"
. (
- (script-stencil . (feta . ("snappizzicato" . "snappizzicato")))
- (padding . 0.20)
- (avoid-slur . outside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("snappizzicato" . "snappizzicato")))
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (direction . ,UP)))
("staccatissimo"
. (
- (avoid-slur . inside)
- (quantize-position . #t)
- (script-stencil . (feta . ("dstaccatissimo" . "ustaccatissimo")))
- (padding . 0.20)
- (skyline-horizontal-padding . 0.10)
- (side-relative-direction . ,DOWN)))
+ (avoid-slur . inside)
+ (quantize-position . #t)
+ (script-stencil . (feta . ("dstaccatissimo" . "ustaccatissimo")))
+ (padding . 0.20)
+ (skyline-horizontal-padding . 0.10)
+ (side-relative-direction . ,DOWN)))
("staccato"
. (
- (script-stencil . (feta . ("staccato" . "staccato")))
- (side-relative-direction . ,DOWN)
- (quantize-position . #t)
- (avoid-slur . inside)
- (toward-stem-shift . 0.5)
- (padding . 0.20)
- (skyline-horizontal-padding . 0.10)
- (script-priority . -100)))
+ (script-stencil . (feta . ("staccato" . "staccato")))
+ (side-relative-direction . ,DOWN)
+ (quantize-position . #t)
+ (avoid-slur . inside)
+ (toward-stem-shift . 0.5)
+ (padding . 0.20)
+ (skyline-horizontal-padding . 0.10)
+ (script-priority . -100)))
("stopped"
. (
- (script-stencil . (feta . ("stopped" . "stopped")))
- (avoid-slur . inside)
- (padding . 0.20)
- (direction . ,UP)))
+ (script-stencil . (feta . ("stopped" . "stopped")))
+ (avoid-slur . inside)
+ (padding . 0.20)
+ (direction . ,UP)))
("tenuto"
. (
- (script-stencil . (feta . ("tenuto" . "tenuto")))
- (quantize-position . #t)
- (avoid-slur . inside)
- (padding . 0.20)
- (side-relative-direction . ,DOWN)))
+ (script-stencil . (feta . ("tenuto" . "tenuto")))
+ (quantize-position . #t)
+ (avoid-slur . inside)
+ (padding . 0.20)
+ (side-relative-direction . ,DOWN)))
("trill"
. (
- (script-stencil . (feta . ("trill" . "trill")))
- (direction . ,UP)
- (padding . 0.20)
- (avoid-slur . outside)
- (script-priority . 2000)))
+ (script-stencil . (feta . ("trill" . "trill")))
+ (direction . ,UP)
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (script-priority . 2000)))
("turn"
. (
- (script-stencil . (feta . ("turn" . "turn")))
- (avoid-slur . inside)
- (padding . 0.20)
- (direction . ,UP)))
+ (script-stencil . (feta . ("turn" . "turn")))
+ (avoid-slur . inside)
+ (padding . 0.20)
+ (direction . ,UP)))
("upbow"
. (
- (script-stencil . (feta . ("upbow" . "upbow")))
- (avoid-slur . around)
- (padding . 0.20)
- (direction . ,UP)
- (script-priority . 150)))
+ (script-stencil . (feta . ("upbow" . "upbow")))
+ (avoid-slur . around)
+ (padding . 0.20)
+ (direction . ,UP)
+ (script-priority . 150)))
("upmordent"
. (
- (script-stencil . (feta . ("upmordent" . "upmordent")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("upmordent" . "upmordent")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("upprall"
. (
- (script-stencil . (feta . ("upprall" . "upprall")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
+ (script-stencil . (feta . ("upprall" . "upprall")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
("varcoda"
. (
- (script-stencil . (feta . ("varcoda" . "varcoda")))
- (padding . 0.20)
- (avoid-slur . outside)
- (direction . ,UP)))
+ (script-stencil . (feta . ("varcoda" . "varcoda")))
+ (padding . 0.20)
+ (avoid-slur . outside)
+ (direction . ,UP)))
("varcomma"
. (
- (script-stencil . (feta . ("lvarcomma" . "rvarcomma")))
- (quantize-position . #t)
- (padding . 0.20)
- (avoid-slur . ignore)
- (direction . ,UP)))
+ (script-stencil . (feta . ("lvarcomma" . "rvarcomma")))
+ (quantize-position . #t)
+ (padding . 0.20)
+ (avoid-slur . ignore)
+ (direction . ,UP)))
("verylongfermata"
. (
- (script-stencil . (feta . ("dverylongfermata" . "uverylongfermata")))
- (padding . 0.20)
- (avoid-slur . around)
- (direction . ,UP)))
- ))
+ (script-stencil . (feta . ("dverylongfermata" . "uverylongfermata")))
+ (padding . 0.20)
+ (avoid-slur . around)
+ (direction . ,UP)))
+ ))
(lambda (record) ((record-predicate ,record) record)))
(set! ,$make-record
(lambda* (#:key ,@slots)
- ((record-constructor ,record) ,@(map car slots*))))
+ ((record-constructor ,record) ,@(map car slots*))))
(set! ,$copy-record
(lambda (record)
(,$make-record ,@(apply
"Return list of all @var{music}'s top-level children."
(let ((elt (ly:music-property music 'element))
(elts (ly:music-property music 'elements))
- (arts (ly:music-property music 'articulations)))
+ (arts (ly:music-property music 'articulations)))
(if (pair? arts)
- (set! elts (append elts arts)))
+ (set! elts (append elts arts)))
(if (null? elt)
- elts
+ elts
(cons elt elts))))
(define-public (find-child music predicate)
(let* ((elt (car queue))
(stop (function elt)))
(process-music (if (boolean? stop)
- (if stop
- (cdr queue)
- (append (music-elements elt) (cdr queue)))
- ((if (cheap-list? stop) append cons)
- stop (cdr queue)))))))
+ (if stop
+ (cdr queue)
+ (append (music-elements elt) (cdr queue)))
+ ((if (cheap-list? stop) append cons)
+ stop (cdr queue)))))))
(process-music (list music)))
(define (tempo->beats music)
(let* ((tempo-spec (find-child-named music 'SequentialMusic))
(tempo (cond
- (tempo-spec
- (let ((tempo-event (find-child-named tempo-spec
- 'TempoChangeEvent)))
- (and tempo-event
- (let ((count (ly:music-property tempo-event
- 'metronome-count)))
- (* (if (pair? count)
- (round (/ (+ (car count) (cdr count)) 2))
- count)
- (duration->number
- (ly:music-property tempo-event 'tempo-unit)))))))
- (else
+ (tempo-spec
+ (let ((tempo-event (find-child-named tempo-spec
+ 'TempoChangeEvent)))
+ (and tempo-event
+ (let ((count (ly:music-property tempo-event
+ 'metronome-count)))
+ (* (if (pair? count)
+ (round (/ (+ (car count) (cdr count)) 2))
+ count)
+ (duration->number
+ (ly:music-property tempo-event 'tempo-unit)))))))
+ (else
(format #t "Programming error (tempo->beats): ~a~%"
- tempo-spec)))))
+ tempo-spec)))))
(debug-enable 'backtrace)
(and tempo
- (set! *default-tempo* (property-value
- (find-child tempo-spec (lambda (elt)
- (music-property? elt 'tempoWholesPerMinute)))))
- (round (* tempo (expt 2 (+ 2 (*base-octave-shift*))))))))
+ (set! *default-tempo* (property-value
+ (find-child tempo-spec (lambda (elt)
+ (music-property? elt 'tempoWholesPerMinute)))))
+ (round (* tempo (expt 2 (+ 2 (*base-octave-shift*))))))))
(defstruct music-context
music
(cond
((music-name? music* 'LyricCombineMusic)
(push! (make-music-context #:music music*
- #:context (ly:music-property music* 'associated-context))
- music-context-list)
+ #:context (ly:music-property music* 'associated-context))
+ music-context-list)
#t)
((and (music-name? music* 'ContextSpeccedMusic)
(music-property-value? music* 'context-type 'Lyrics)
(let ((name-node (find-child music* (lambda (node) (music-property? node 'associatedVoice)))))
(if name-node
(push! (make-music-context #:music music* #:context (property-value name-node))
- music-context-list)))
+ music-context-list)))
#t)
(else
#f))))
((music-name? music '(EventChord LyricEvent))
(let ((lyric-event (find-child-named music 'LyricEvent)))
(push! (make-lyrics
- #:text (ly:music-property lyric-event 'text)
- #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4)
- #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent))
- #:ignore-melismata ignore-melismata
- #:context current-voice)
- lyrics-list))
+ #:text (ly:music-property lyric-event 'text)
+ #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4)
+ #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent))
+ #:ignore-melismata ignore-melismata
+ #:context current-voice)
+ lyrics-list))
;; LilyPond delays applying settings
(set! ignore-melismata next-ignore-melismata)
(set! current-voice next-current-voice)
;; skipping
((music-name? music 'SkipMusic)
(push! (make-skip
- #:duration (* (duration->number (ly:music-property music 'duration)) 4)
- #:context current-voice)
- lyrics-list)
+ #:duration (* (duration->number (ly:music-property music 'duration)) 4)
+ #:context current-voice)
+ lyrics-list)
#t)
;; parameter change
((music-property? music 'ignoreMelismata)
(let ((context (ly:music-property music 'context-id))
(children (music-elements music)))
(add! (make-score-voice #:context (debug "Changing context" context)
- #:elements (append-map (lambda (elt)
- (get-notes* elt autobeaming))
- children))
- result-list))
+ #:elements (append-map (lambda (elt)
+ (get-notes* elt autobeaming))
+ children))
+ result-list))
#t)
;; timing change
((music-property? music 'timeSignatureFraction)
(let ((repeat-count (ly:music-property music 'repeat-count))
(children (music-elements music)))
(add! (make-score-repetice #:count repeat-count
- #:elements (append-map
- (lambda (elt) (get-notes* elt autobeaming))
- children))
- result-list))
+ #:elements (append-map
+ (lambda (elt) (get-notes* elt autobeaming))
+ children))
+ result-list))
#t)
;; a note or rest
((or (music-name? music 'EventChord)
events))))
(set! in-slur (+ in-slur slur-start (- slur-end)))
(let ((note-spec (make-note #:pitch pitch #:duration duration #:joined in-slur
- #:origin (ly:music-property note 'origin)))
+ #:origin (ly:music-property note 'origin)))
(last-result (and (not (null? result-list)) (last result-list))))
(set! last-note-spec note-spec)
(if (and last-result
(debug "Rest" rest)
(let* ((duration (* (duration->number (ly:music-property rest 'duration)) 4))
(rest-spec (make-rest #:duration duration
- #:origin (ly:music-property rest 'origin)))
+ #:origin (ly:music-property rest 'origin)))
(last-result (and (not (null? result-list)) (last result-list))))
(if (and last-result
(score-notes? last-result))
(set-score-notes-note/rest-list! last-result
- (append (score-notes-note/rest-list last-result)
- (list rest-spec)))
+ (append (score-notes-note/rest-list last-result)
+ (list rest-spec)))
(add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))))))
- (filter
- (lambda (m)
- (not (music-name? m '(RestEvent
- NoteEvent
- LyricEvent
- MultiMeasureRestEvent))))
- (ly:music-property music 'elements)))
- ((music-name? music '(RestEvent
- NoteEvent
- LyricEvent
- MultiMeasureRestEvent))
- (make-music 'EventChord
- 'elements
- (cons music
- (ly:music-property music 'articulations))))
+ (filter
+ (lambda (m)
+ (not (music-name? m '(RestEvent
+ NoteEvent
+ LyricEvent
+ MultiMeasureRestEvent))))
+ (ly:music-property music 'elements)))
+ ((music-name? music '(RestEvent
+ NoteEvent
+ LyricEvent
+ MultiMeasureRestEvent))
+ (make-music 'EventChord
+ 'elements
+ (cons music
+ (ly:music-property music 'articulations))))
;; autobeaming change
((music-property? music 'autoBeaming)
(set! autobeaming (property-value music))
(set! in-slur (+ in-slur change))
(if last-note-spec
(set-note-joined! last-note-spec (+ (note-joined last-note-spec) change))))
- #t)
+ #t)
;; tempo change
((music-property? music 'tempoWholesPerMinute)
(set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music)))
- #t)
+ #t)
;; breathe
((music-name? music 'BreathingEvent)
(if last-note-spec
(let* ((note-duration (note-duration last-note-spec))
(rest-spec (make-rest #:duration (* note-duration (- 1 (*breathe-shortage*)))
- #:origin (ly:music-property music 'origin))))
+ #:origin (ly:music-property music 'origin))))
(set-note-duration! last-note-spec (* note-duration (*breathe-shortage*)))
(add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))
(warning music "\\\\breathe without previous note known"))
- #t)
+ #t)
;; anything else
(else
#f))))
(let ((new-context (score-voice-context score)))
(if (equal? new-context lyrics-context)
(insert-lyrics*! lyrics/skip-list
- (append (score-voice-elements score)
- (if (null? (cdr score-list))
- '()
- (list (make-score-voice #:context context
- #:elements (cdr score-list)))))
- new-context)
+ (append (score-voice-elements score)
+ (if (null? (cdr score-list))
+ '()
+ (list (make-score-voice #:context context
+ #:elements (cdr score-list)))))
+ new-context)
(insert-lyrics*! lyrics/skip-list (cdr score-list) context))))
((score-choice? score)
(let* ((lists* (score-choice-lists score))
(score* #f))
(while (and (not score*)
(not (null? lists)))
- (set! score* (find-lyrics-score (car lists) lyrics-context allow-default))
- (set! lists (cdr lists))
- (if (not score*)
- (set! n (+ n 1)))
- (if (and (null? lists)
- (not allow-default)
- (equal? lyrics-context context))
- (begin
- (set! allow-default #t)
- (set! n 0)
- (set! lists (score-choice-lists score)))))
+ (set! score* (find-lyrics-score (car lists) lyrics-context allow-default))
+ (set! lists (cdr lists))
+ (if (not score*)
+ (set! n (+ n 1)))
+ (if (and (null? lists)
+ (not allow-default)
+ (equal? lyrics-context context))
+ (begin
+ (set! allow-default #t)
+ (set! n 0)
+ (set! lists (score-choice-lists score)))))
(debug "Selected score" score*)
(if (and score*
(>= n n-assigned))
(begin
(if (> n n-assigned)
(receive (assigned-elts unassigned-elts) (split-at lists* n-assigned)
- (set-score-choice-lists! score (append assigned-elts
- (list (list-ref lists* n))
- (take unassigned-elts (- n n-assigned))
- lists))))
+ (set-score-choice-lists! score (append assigned-elts
+ (list (list-ref lists* n))
+ (take unassigned-elts (- n n-assigned))
+ lists))))
(set-score-choice-n-assigned! score (+ n-assigned 1))))
(insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()) (cdr score-list)) context)))
((score-repetice? score)
(insert-lyrics*! lyrics/skip-list
- (append (score-repetice-elements score) (cdr score-list)) context))
+ (append (score-repetice-elements score) (cdr score-list)) context))
((score-notes? score)
;; This is the only part which actually attaches the processed lyrics.
;; The subsequent calls return verses which we collect into a verse block.
(unfinished-verse #f)
(verse-list '()))
(while (not (null? note-list))
- (if (null? lyrics/skip-list)
- (let ((final-rests '()))
- (while (and (not (null? note-list))
- (rest? (car note-list)))
- (push! (car note-list) final-rests)
- (set! note-list (cdr note-list)))
- (if (not (null? final-rests))
- (set! verse-list (append verse-list
- (list (make-verse #:text ""
+ (if (null? lyrics/skip-list)
+ (let ((final-rests '()))
+ (while (and (not (null? note-list))
+ (rest? (car note-list)))
+ (push! (car note-list) final-rests)
+ (set! note-list (cdr note-list)))
+ (if (not (null? final-rests))
+ (set! verse-list (append verse-list
+ (list (make-verse #:text ""
#:notelist/rests (reverse! final-rests))))))
- (if (not (null? note-list))
- (begin
- (warning (car note-list) "Missing lyrics: ~a ~a" context note-list)
- (set! note-list '()))))
- (let ((lyrics/skip (car lyrics/skip-list)))
- (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip)
- (consume-lyrics-notes lyrics/skip note-list context)
- (consume-skip-notes lyrics/skip note-list context))
- (debug "Consumed notes" (list lyrics/skip notelist/rest))
- (set! note-list note-list*)
- (cond
- ((null? notelist/rest)
- #f)
- ;; Lyrics
- ((and (lyrics? lyrics/skip)
- unfinished-verse)
- (set-verse-text!
- unfinished-verse
- (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip)))
- (set-verse-notelist/rests!
- unfinished-verse
- (append (verse-notelist/rests unfinished-verse) (list notelist/rest)))
- (if (not (lyrics-unfinished lyrics/skip))
- (set! unfinished-verse #f)))
- ((lyrics? lyrics/skip)
- (let ((verse (make-verse #:text (if (rest? notelist/rest)
- ""
- (lyrics-text lyrics/skip))
- #:notelist/rests (list notelist/rest))))
- (add! verse verse-list)
- (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f))))
- ;; Skip
- ((skip? lyrics/skip)
- (cond
- ((rest? notelist/rest)
- (if (null? verse-list)
- (set! verse-list (list (make-verse #:text ""
- #:notelist/rests (list notelist/rest))))
- (let ((last-verse (last verse-list)))
- (set-verse-notelist/rests!
- last-verse
- (append (verse-notelist/rests last-verse) (list notelist/rest))))))
- ((pair? notelist/rest)
- (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest))
- verse-list))
- (else
- (error "Unreachable branch reached")))
- (set! unfinished-verse #f)))
- (if (not (rest? notelist/rest))
- (set! lyrics/skip-list (cdr lyrics/skip-list)))))))
+ (if (not (null? note-list))
+ (begin
+ (warning (car note-list) "Missing lyrics: ~a ~a" context note-list)
+ (set! note-list '()))))
+ (let ((lyrics/skip (car lyrics/skip-list)))
+ (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip)
+ (consume-lyrics-notes lyrics/skip note-list context)
+ (consume-skip-notes lyrics/skip note-list context))
+ (debug "Consumed notes" (list lyrics/skip notelist/rest))
+ (set! note-list note-list*)
+ (cond
+ ((null? notelist/rest)
+ #f)
+ ;; Lyrics
+ ((and (lyrics? lyrics/skip)
+ unfinished-verse)
+ (set-verse-text!
+ unfinished-verse
+ (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip)))
+ (set-verse-notelist/rests!
+ unfinished-verse
+ (append (verse-notelist/rests unfinished-verse) (list notelist/rest)))
+ (if (not (lyrics-unfinished lyrics/skip))
+ (set! unfinished-verse #f)))
+ ((lyrics? lyrics/skip)
+ (let ((verse (make-verse #:text (if (rest? notelist/rest)
+ ""
+ (lyrics-text lyrics/skip))
+ #:notelist/rests (list notelist/rest))))
+ (add! verse verse-list)
+ (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f))))
+ ;; Skip
+ ((skip? lyrics/skip)
+ (cond
+ ((rest? notelist/rest)
+ (if (null? verse-list)
+ (set! verse-list (list (make-verse #:text ""
+ #:notelist/rests (list notelist/rest))))
+ (let ((last-verse (last verse-list)))
+ (set-verse-notelist/rests!
+ last-verse
+ (append (verse-notelist/rests last-verse) (list notelist/rest))))))
+ ((pair? notelist/rest)
+ (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest))
+ verse-list))
+ (else
+ (error "Unreachable branch reached")))
+ (set! unfinished-verse #f)))
+ (if (not (rest? notelist/rest))
+ (set! lyrics/skip-list (cdr lyrics/skip-list)))))))
(if unfinished-verse
(set-verse-unfinished! unfinished-verse #t))
(set-score-notes-verse-block-list!
(consumed '()))
(while (and join
(not (null? note-list)))
- (let ((note (car note-list)))
- (push! note consumed)
- (let ((note-slur (note-joined note)))
- (if (< note-slur 0)
- (warning note "Slur underrun"))
- (set! join (and (not ignore-melismata) (> note-slur 0)))))
- (set! note-list (cdr note-list)))
+ (let ((note (car note-list)))
+ (push! note consumed)
+ (let ((note-slur (note-joined note)))
+ (if (< note-slur 0)
+ (warning note "Slur underrun"))
+ (set! join (and (not ignore-melismata) (> note-slur 0)))))
+ (set! note-list (cdr note-list)))
(if join
(warning (safe-car (if (null? note-list) consumed note-list))
"Unfinished slur: ~a ~a" context consumed))
(consumed '()))
(while (and (> duration epsilon)
(not (null? note-list)))
- (let ((note (car note-list)))
- (assert (note? note))
- (push! note consumed)
- (set! duration (- duration (note-duration note))))
- (set! note-list (cdr note-list)))
+ (let ((note (car note-list)))
+ (assert (note? note))
+ (push! note consumed)
+ (set! duration (- duration (note-duration note))))
+ (set! note-list (cdr note-list)))
(set! consumed (reverse! consumed))
(cond
((> duration epsilon)
(warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
- "Excessive skip: ~a ~a ~a ~a" context skip duration consumed))
+ "Excessive skip: ~a ~a ~a ~a" context skip duration consumed))
((< duration (- epsilon))
(warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
- "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed)))
+ "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed)))
(values (if (*skip-word*)
consumed
'())
(score-choice-lists score)))))
((score-repetice? score)
(list (make-repeated-blocks #:count (score-repetice-count score)
- #:block-list (append-map extract-verse-blocks
- (score-repetice-elements score)))))
+ #:block-list (append-map extract-verse-blocks
+ (score-repetice-elements score)))))
((score-notes? score)
(list (make-parallel-blocks #:block-list (score-notes-verse-block-list score))))
(else
(debug "Final score list" score-list)
(let ((verse-block-list (debug "Verse blocks" (append-map extract-verse-blocks score-list))))
(letrec ((combine (lambda (lst-1 lst-2)
- (debug "Combining lists" (list lst-1 lst-2))
- (if (null? lst-2)
- lst-1
- (let ((diff (- (length lst-1) (length lst-2))))
- (if (< diff 0)
- (let ((last-elt (last lst-1)))
- (while (< diff 0)
- (add! last-elt lst-1)
- (set! diff (+ diff 1))))
- (let ((last-elt (last lst-2)))
- (while (> diff 0)
- (add! last-elt lst-2)
- (set! diff (- diff 1)))))
- (debug "Combined" (map append lst-1 lst-2))))))
+ (debug "Combining lists" (list lst-1 lst-2))
+ (if (null? lst-2)
+ lst-1
+ (let ((diff (- (length lst-1) (length lst-2))))
+ (if (< diff 0)
+ (let ((last-elt (last lst-1)))
+ (while (< diff 0)
+ (add! last-elt lst-1)
+ (set! diff (+ diff 1))))
+ (let ((last-elt (last lst-2)))
+ (while (> diff 0)
+ (add! last-elt lst-2)
+ (set! diff (- diff 1)))))
+ (debug "Combined" (map append lst-1 lst-2))))))
(expand* (lambda (block)
(cond
((parallel-blocks? block)
(expanded (expand (repeated-blocks-block-list block)))
(expanded* '()))
(while (not (null? expanded))
- (let ((count* count)
- (item '()))
- (while (and (> count* 0) (not (null? expanded)))
- (set! item (append item (car expanded)))
- (set! expanded (cdr expanded))
- (set! count* (- count* 1)))
- (push! item expanded*)))
+ (let ((count* count)
+ (item '()))
+ (while (and (> count* 0) (not (null? expanded)))
+ (set! item (append item (car expanded)))
+ (set! expanded (cdr expanded))
+ (set! count* (- count* 1)))
+ (push! item expanded*)))
(reverse expanded*)))
(else
(list (list block))))))
(if (null? block-list)
'()
(debug "Expanded" (combine (expand* (car block-list))
- (expand (cdr block-list)))))))
+ (expand (cdr block-list)))))))
(merge (lambda (verse-list)
(cond
((null? verse-list)
(let ((verse-1 (first verse-list))
(verse-2 (second verse-list)))
(merge (cons (make-verse #:text (string-append (verse-text verse-1)
- (verse-text verse-2))
- #:notelist/rests (append (verse-notelist/rests verse-1)
- (verse-notelist/rests verse-2))
- #:unfinished (verse-unfinished verse-2))
+ (verse-text verse-2))
+ #:notelist/rests (append (verse-notelist/rests verse-1)
+ (verse-notelist/rests verse-2))
+ #:unfinished (verse-unfinished verse-2))
(cddr verse-list)))))
(else
(cons (car verse-list) (merge (cdr verse-list))))))))
(debug "Final verses" (merge (append-map (lambda (lst) (append-map verse-block-verse-list lst))
- (expand verse-block-list)))))))
+ (expand verse-block-list)))))))
(define (handle-music music)
;; Returns list of verses.
(define festival-note-mapping '((0 "C") (1 "C#") (2 "D") (3 "D#") (4 "E") (5 "F") (6 "F#")
- (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B")))
+ (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B")))
(define (festival-pitch pitch)
(let* ((semitones (ly:pitch-semitones pitch))
(octave (inexact->exact (floor (/ semitones 12))))
(let ((text (verse-text verse))
(note/rest-list (verse-notelist/rests verse)))
(receive (rest-list note-listlist) (partition rest? note/rest-list)
- (debug "Rest list" rest-list)
- (debug "Note list" note-listlist)
- (if (not (null? rest-list))
- (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list)))))
- (if (not (null? note-listlist))
- (begin
- (if (> rest-dur 0)
- (begin
- (write-rest-element port rest-dur)
- (set! rest-dur 0)))
- (write-lyrics-element port text note-listlist))))))
+ (debug "Rest list" rest-list)
+ (debug "Note list" note-listlist)
+ (if (not (null? rest-list))
+ (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list)))))
+ (if (not (null? note-listlist))
+ (begin
+ (if (> rest-dur 0)
+ (begin
+ (write-rest-element port rest-dur)
+ (set! rest-dur 0)))
+ (write-lyrics-element port text note-listlist))))))
(handle-music music))
(if (> rest-dur 0)
(write-rest-element port rest-dur))))
(define (gulp-file name)
(let* ((file (open-input-file name))
- (text (read-delimited "" file)))
+ (text (read-delimited "" file)))
(close file)
text))
(define (scm-gulp-file name)
- (set! %load-path
- (cons (string-append (getenv "LILYPOND_DATADIR") "/ly")
- (cons (string-append (getenv "LILYPOND_DATADIR") "/ps")
- %load-path)))
+ (set! %load-path
+ (cons (string-append (getenv "LILYPOND_DATADIR") "/ly")
+ (cons (string-append (getenv "LILYPOND_DATADIR") "/ps")
+ %load-path)))
(let ((path (%search-load-path name)))
- (if path
- (gulp-file path)
- (gulp-file name))))
+ (if path
+ (gulp-file path)
+ (gulp-file name))))
(define (scm-number->string x)
(let ((e (inexact->exact x)))
(string-append (if (= e x)
- (number->string e)
- (number->string x))
- " ")))
+ (number->string e)
+ (number->string x))
+ " ")))
(define ly:gulp-file scm-gulp-file)
(define ly:number->string scm-number->string)
,(car (list-ref coords 6))
,(cdr (list-ref coords 6))
closepath)))
- (ly:make-stencil
- `(path ,thick `(,@' ,command-list) 'round 'round #t)
- xext
- yext)))
+ (ly:make-stencil
+ `(path ,thick `(,@' ,command-list) 'round 'round #t)
+ xext
+ yext)))
(define-public (stack-stencils axis dir padding stils)
"Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
"Add brackets around @var{stil}, producing a new stencil."
(let* ((ext (ly:stencil-extent stil axis))
- (lb (ly:bracket axis ext thick protrusion))
- (rb (ly:bracket axis ext thick (- protrusion))))
+ (lb (ly:bracket axis ext thick protrusion))
+ (rb (ly:bracket axis ext thick (- protrusion))))
(set! stil
- (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
+ (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
(set! stil
- (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
+ (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
stil))
(define (make-parenthesis-stencil
- y-extent half-thickness width angularity)
+ y-extent half-thickness width angularity)
"Create a parenthesis stencil.
@var{y-extent} is the Y extent of the markup inside the parenthesis.
@var{half-thickness} is the half thickness of the parenthesis.
The higher the value of number @var{angularity},
the more angular the shape of the parenthesis."
(let* ((line-width 0.1)
- ;; Horizontal position of baseline that end points run through.
- (base-x
- (if (< width 0)
- (- width)
- 0))
+ ;; Horizontal position of baseline that end points run through.
+ (base-x
+ (if (< width 0)
+ (- width)
+ 0))
;; X value farthest from baseline on outside of curve
(outer-x (+ base-x width))
;; X extent of bezier sandwich centerline curves
(x-extent (ordered-cons base-x outer-x))
- (bottom-y (interval-start y-extent))
- (top-y (interval-end y-extent))
-
- (lower-end-point (cons base-x bottom-y))
- (upper-end-point (cons base-x top-y))
-
- (outer-control-x (+ base-x (* 4/3 width)))
- (inner-control-x (+ outer-control-x
- (if (< width 0)
- half-thickness
- (- half-thickness))))
-
- ;; Vertical distance between a control point
- ;; and the end point it connects to.
- (offset-index (- (* 0.6 angularity) 0.8))
- (lower-control-y (interval-index y-extent offset-index))
- (upper-control-y (interval-index y-extent (- offset-index)))
-
- (lower-outer-control-point
- (cons outer-control-x lower-control-y))
- (upper-outer-control-point
- (cons outer-control-x upper-control-y))
- (upper-inner-control-point
- (cons inner-control-x upper-control-y))
- (lower-inner-control-point
- (cons inner-control-x lower-control-y)))
+ (bottom-y (interval-start y-extent))
+ (top-y (interval-end y-extent))
+
+ (lower-end-point (cons base-x bottom-y))
+ (upper-end-point (cons base-x top-y))
+
+ (outer-control-x (+ base-x (* 4/3 width)))
+ (inner-control-x (+ outer-control-x
+ (if (< width 0)
+ half-thickness
+ (- half-thickness))))
+
+ ;; Vertical distance between a control point
+ ;; and the end point it connects to.
+ (offset-index (- (* 0.6 angularity) 0.8))
+ (lower-control-y (interval-index y-extent offset-index))
+ (upper-control-y (interval-index y-extent (- offset-index)))
+
+ (lower-outer-control-point
+ (cons outer-control-x lower-control-y))
+ (upper-outer-control-point
+ (cons outer-control-x upper-control-y))
+ (upper-inner-control-point
+ (cons inner-control-x upper-control-y))
+ (lower-inner-control-point
+ (cons inner-control-x lower-control-y)))
(make-bezier-sandwich-stencil
- (list
- ;; Step 4: curve through inner control points
- ;; to lower end point.
- upper-inner-control-point
- lower-inner-control-point
- lower-end-point
- ;; Step 3: move to upper end point.
- upper-end-point
- ;; Step 2: curve through outer control points
- ;; to upper end point.
- lower-outer-control-point
- upper-outer-control-point
- upper-end-point
- ;; Step 1: move to lower end point.
- lower-end-point)
- line-width
- (interval-widen x-extent (/ line-width 2))
- (interval-widen y-extent (/ line-width 2)))))
+ (list
+ ;; Step 4: curve through inner control points
+ ;; to lower end point.
+ upper-inner-control-point
+ lower-inner-control-point
+ lower-end-point
+ ;; Step 3: move to upper end point.
+ upper-end-point
+ ;; Step 2: curve through outer control points
+ ;; to upper end point.
+ lower-outer-control-point
+ upper-outer-control-point
+ upper-end-point
+ ;; Step 1: move to lower end point.
+ lower-end-point)
+ line-width
+ (interval-widen x-extent (/ line-width 2))
+ (interval-widen y-extent (/ line-width 2)))))
(define-public (parenthesize-stencil
- stencil half-thickness width angularity padding)
+ stencil half-thickness width angularity padding)
"Add parentheses around @var{stencil}, returning a new stencil."
(let* ((y-extent (ly:stencil-extent stencil Y))
- (lp (make-parenthesis-stencil
- y-extent half-thickness (- width) angularity))
- (rp (make-parenthesis-stencil
- y-extent half-thickness width angularity)))
+ (lp (make-parenthesis-stencil
+ y-extent half-thickness (- width) angularity))
+ (rp (make-parenthesis-stencil
+ y-extent half-thickness width angularity)))
(set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding))
(set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
stencil))
(let ((xext (cons (min startx endx) (max startx endx)))
(yext (cons (min starty endy) (max starty endy))))
(ly:make-stencil
- (list 'draw-line width startx starty endx endy)
- ;; Since the line has rounded edges, we have to / can safely add half the
- ;; width to all coordinates!
- (interval-widen xext (/ width 2))
- (interval-widen yext (/ width 2)))))
+ (list 'draw-line width startx starty endx endy)
+ ;; Since the line has rounded edges, we have to / can safely add half the
+ ;; width to all coordinates!
+ (interval-widen xext (/ width 2))
+ (interval-widen yext (/ width 2)))))
(define-public (make-filled-box-stencil xext yext)
"Make a filled box."
(ly:make-stencil
- (list 'round-filled-box (- (car xext)) (cdr xext)
- (- (car yext)) (cdr yext) 0.0)
- xext yext))
+ (list 'round-filled-box (- (car xext)) (cdr xext)
+ (- (car yext)) (cdr yext) 0.0)
+ xext yext))
(define-public (make-circle-stencil radius thickness fill)
"Make a circle of radius @var{radius} and thickness @var{thickness}."
(let*
((out-radius (+ radius (/ thickness 2.0))))
- (ly:make-stencil
- (list 'circle radius thickness fill)
- (cons (- out-radius) out-radius)
- (cons (- out-radius) out-radius))))
+ (ly:make-stencil
+ (list 'circle radius thickness fill)
+ (cons (- out-radius) out-radius)
+ (cons (- out-radius) out-radius))))
(define-public (make-oval-stencil x-radius y-radius thickness fill)
"Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
,(list 'curveto x-min y-min x-max y-min x-max 0)
,(list 'closepath)))
(command-list (fold-right append '() commands)))
- (ly:make-stencil
- `(path ,thickness `(,@',command-list) 'round 'round ,fill)
- (cons (- x-out-radius) x-out-radius)
- (cons (- y-out-radius) y-out-radius))))
+ (ly:make-stencil
+ `(path ,thickness `(,@',command-list) 'round 'round ,fill)
+ (cons (- x-out-radius) x-out-radius)
+ (cons (- y-out-radius) y-out-radius))))
(define-public
(make-partial-ellipse-stencil
- x-radius y-radius start-angle end-angle thick connect fill)
+ x-radius y-radius start-angle end-angle thick connect fill)
"Create an elliptical arc
@var{x-radius} is the X radius of the arc.
@var{y-radius} is the Y radius of the arc.
(helper ordering-function value left-list right-list cutl? cutr?)
(if (null? right-list)
(append
- (if cutl? '() left-list)
- (list value)
- (if cutr? '() right-list))
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
(if (ordering-function value (car right-list))
(append
- (if cutl? '() left-list)
- (list value)
- (if cutr? '() right-list))
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
(helper
- ordering-function
- value
- (append left-list (list (car right-list)))
- (cdr right-list)
- cutl?
- cutr?))))
+ ordering-function
+ value
+ (append left-list (list (car right-list)))
+ (cdr right-list)
+ cutl?
+ cutr?))))
(helper ordering-function value '() inlist cutl? cutr?))
(define (ordering-function-1 a b) (car< a b))
;; we want the end angle to always be bigger than the start angle
;; so we redefine it here just in case it is less
(new-end-angle
- (if (<= new-end-angle new-start-angle)
- (+ TWO-PI new-end-angle)
- new-end-angle))
+ (if (<= new-end-angle new-start-angle)
+ (+ TWO-PI new-end-angle)
+ new-end-angle))
;; all the points that may be extrema of the arc
;; this is the 90 degree points plus the beginning and end points
;; we use this to calculate extents
(possible-extrema
+ (insert-in-ordered-list
+ ordering-function-2
+ (cons new-end-angle rectangular-end-radius)
(insert-in-ordered-list
- ordering-function-2
- (cons new-end-angle rectangular-end-radius)
- (insert-in-ordered-list
- ordering-function-1
- (cons new-start-angle rectangular-start-radius)
- radius-list
- #t
- #f)
- #f
- #t)))
+ ordering-function-1
+ (cons new-start-angle rectangular-start-radius)
+ radius-list
+ #t
+ #f)
+ #f
+ #t)))
(ly:make-stencil
- (list
- 'partial-ellipse
- x-radius
- y-radius
- start-angle
- end-angle
- thick
- connect
- fill)
- ;; we know the extrema points by crawling through the
- ;; list of possible extrema and finding the min and max
- ;; for x and y
- (cons (min-max-crawler min cadr possible-extrema)
- (min-max-crawler max cadr possible-extrema))
- (cons (min-max-crawler min cddr possible-extrema)
- (min-max-crawler max cddr possible-extrema)))))
+ (list
+ 'partial-ellipse
+ x-radius
+ y-radius
+ start-angle
+ end-angle
+ thick
+ connect
+ fill)
+ ;; we know the extrema points by crawling through the
+ ;; list of possible extrema and finding the min and max
+ ;; for x and y
+ (cons (min-max-crawler min cadr possible-extrema)
+ (min-max-crawler max cadr possible-extrema))
+ (cons (min-max-crawler min cddr possible-extrema)
+ (min-max-crawler max cddr possible-extrema)))))
(define (line-part-min-max x1 x2)
(list (min x1 x2) (max x1 x2)))
(define (bezier-part-min-max x1 x2 x3 x4)
((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
- (map
- (lambda (x)
- (+ (* x1 (expt (- 1 x) 3))
- (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
- (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
- (* x4 (expt x 3))))))
- (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
- (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
+ (map
+ (lambda (x)
+ (+ (* x1 (expt (- 1 x) 3))
+ (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
+ (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
+ (* x4 (expt x 3))))))
+ (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
+ (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
+ (list 0.0 1.0)
+ (filter
+ (lambda (x) (and (>= x 0) (<= x 1)))
+ (append
(list 0.0 1.0)
- (filter
- (lambda (x) (and (>= x 0) (<= x 1)))
- (append
- (list 0.0 1.0)
- (map (lambda (op)
- (if (not (eqv? 0.0
- (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
- ;; Zeros of the bezier curve
- (/ (+ (- x1 (* 2 x2))
- (op x3
- (sqrt (- (+ (expt x2 2)
- (+ (expt x3 2) (* x1 x4)))
- (+ (* x1 x3)
- (+ (* x2 x4) (* x2 x3)))))))
- (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
- ;; Apply L'hopital's rule to get the zeros if 0/0
- (* (op 0 1)
- (/ (/ (- x4 x3) 2)
- (sqrt (- (+ (* x2 x2)
- (+ (* x3 x3) (* x1 x4)))
+ (map (lambda (op)
+ (if (not (eqv? 0.0
+ (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
+ ;; Zeros of the bezier curve
+ (/ (+ (- x1 (* 2 x2))
+ (op x3
+ (sqrt (- (+ (expt x2 2)
+ (+ (expt x3 2) (* x1 x4)))
(+ (* x1 x3)
- (+ (* x2 x4) (* x2 x3)))))))))
- (list + -))))))))
+ (+ (* x2 x4) (* x2 x3)))))))
+ (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
+ ;; Apply L'hopital's rule to get the zeros if 0/0
+ (* (op 0 1)
+ (/ (/ (- x4 x3) 2)
+ (sqrt (- (+ (* x2 x2)
+ (+ (* x3 x3) (* x1 x4)))
+ (+ (* x1 x3)
+ (+ (* x2 x4) (* x2 x3)))))))))
+ (list + -))))))))
(define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
(map (lambda (x)
((lambda (x)
(list
- (reduce min +inf.0 (map caar x))
- (reduce max -inf.0 (map cadar x))
- (reduce min +inf.0 (map caadr x))
- (reduce max -inf.0 (map cadadr x))))
- (map (lambda (x)
- (if (= (length x) 8)
- (apply bezier-min-max x)
- (apply line-min-max x)))
- (map (lambda (x y)
- (append (list (cadr (reverse x)) (car (reverse x))) y))
- (append (list origin)
- (reverse (cdr (reverse pointlist)))) pointlist))))
+ (reduce min +inf.0 (map caar x))
+ (reduce max -inf.0 (map cadar x))
+ (reduce min +inf.0 (map caadr x))
+ (reduce max -inf.0 (map cadadr x))))
+ (map (lambda (x)
+ (if (= (length x) 8)
+ (apply bezier-min-max x)
+ (apply line-min-max x)))
+ (map (lambda (x y)
+ (append (list (cadr (reverse x)) (car (reverse x))) y))
+ (append (list origin)
+ (reverse (cdr (reverse pointlist)))) pointlist))))
(define-public (make-connected-path-stencil pointlist thickness
- x-scale y-scale connect fill)
+ x-scale y-scale connect fill)
"Make a connected path described by the list @var{pointlist}, with
thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are
;; paths using this routine are designed to begin at point '(0 . 0)
(let* ((origin (list 0 0))
- (boundlist (path-min-max origin pointlist))
- ;; modify pointlist to scale the coordinates
- (path (map (lambda (x)
- (apply
- (if (= 6 (length x))
- (lambda (x1 x2 x3 x4 x5 x6)
- (list 'curveto
- (* x1 x-scale)
- (* x2 y-scale)
- (* x3 x-scale)
- (* x4 y-scale)
- (* x5 x-scale)
- (* x6 y-scale)))
- (lambda (x1 x2)
- (list 'lineto
- (* x1 x-scale)
- (* x2 y-scale))))
- x))
- pointlist))
- ;; a path must begin with a `moveto'
- (prepend-origin (apply list (cons 'moveto origin) path))
- ;; if this path is connected, add closepath to the end
- (final-path (if connect
- (append prepend-origin (list 'closepath))
- prepend-origin))
- (command-list (fold-right append '() final-path)))
- (ly:make-stencil
- `(path ,thickness
- `(,@',command-list)
- 'round
- 'round
- ,(if fill #t #f))
- (coord-translate
+ (boundlist (path-min-max origin pointlist))
+ ;; modify pointlist to scale the coordinates
+ (path (map (lambda (x)
+ (apply
+ (if (= 6 (length x))
+ (lambda (x1 x2 x3 x4 x5 x6)
+ (list 'curveto
+ (* x1 x-scale)
+ (* x2 y-scale)
+ (* x3 x-scale)
+ (* x4 y-scale)
+ (* x5 x-scale)
+ (* x6 y-scale)))
+ (lambda (x1 x2)
+ (list 'lineto
+ (* x1 x-scale)
+ (* x2 y-scale))))
+ x))
+ pointlist))
+ ;; a path must begin with a `moveto'
+ (prepend-origin (apply list (cons 'moveto origin) path))
+ ;; if this path is connected, add closepath to the end
+ (final-path (if connect
+ (append prepend-origin (list 'closepath))
+ prepend-origin))
+ (command-list (fold-right append '() final-path)))
+ (ly:make-stencil
+ `(path ,thickness
+ `(,@',command-list)
+ 'round
+ 'round
+ ,(if fill #t #f))
+ (coord-translate
((if (< x-scale 0) reverse-interval identity)
- (cons (* x-scale (list-ref boundlist 0))
- (* x-scale (list-ref boundlist 1))))
- `(,(/ thickness -2) . ,(/ thickness 2)))
- (coord-translate
+ (cons (* x-scale (list-ref boundlist 0))
+ (* x-scale (list-ref boundlist 1))))
+ `(,(/ thickness -2) . ,(/ thickness 2)))
+ (coord-translate
((if (< y-scale 0) reverse-interval identity)
- (cons (* y-scale (list-ref boundlist 2))
- (* y-scale (list-ref boundlist 3))))
- `(,(/ thickness -2) . ,(/ thickness 2))))))
+ (cons (* y-scale (list-ref boundlist 2))
+ (* y-scale (list-ref boundlist 3))))
+ `(,(/ thickness -2) . ,(/ thickness 2))))))
(define-public (make-ellipse-stencil x-radius y-radius thickness fill)
"Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
((x-out-radius (+ x-radius (/ thickness 2.0)))
(y-out-radius (+ y-radius (/ thickness 2.0))) )
- (ly:make-stencil
- (list 'ellipse x-radius y-radius thickness fill)
- (cons (- x-out-radius) x-out-radius)
- (cons (- y-out-radius) y-out-radius))))
+ (ly:make-stencil
+ (list 'ellipse x-radius y-radius thickness fill)
+ (cons (- x-out-radius) x-out-radius)
+ (cons (- y-out-radius) y-out-radius))))
(define-public (box-grob-stencil grob)
"Make a box of exactly the extents of the grob. The box precisely
encloses the contents."
(let* ((xext (ly:grob-extent grob grob 0))
- (yext (ly:grob-extent grob grob 1))
- (thick 0.01))
+ (yext (ly:grob-extent grob grob 1))
+ (thick 0.01))
(ly:stencil-add
(make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
(define-public (box-stencil stencil thickness padding)
"Add a box around @var{stencil}, producing a new stencil."
(let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
- (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
- (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
- (x-rule (make-filled-box-stencil
- (interval-widen x-ext thickness) (cons 0 thickness))))
+ (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
+ (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
+ (x-rule (make-filled-box-stencil
+ (interval-widen x-ext thickness) (cons 0 thickness))))
(set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
(set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
(set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
(define-public (circle-stencil stencil thickness padding)
"Add a circle around @var{stencil}, producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
- (y-ext (ly:stencil-extent stencil Y))
- (diameter (max (interval-length x-ext)
+ (y-ext (ly:stencil-extent stencil Y))
+ (diameter (max (interval-length x-ext)
(interval-length y-ext)))
- (radius (+ (/ diameter 2) padding thickness))
- (circle (make-circle-stencil radius thickness #f)))
+ (radius (+ (/ diameter 2) padding thickness))
+ (circle (make-circle-stencil radius thickness #f)))
(ly:stencil-add
stencil
(ly:stencil-translate circle
- (cons
- (interval-center x-ext)
- (interval-center y-ext))))))
+ (cons
+ (interval-center x-ext)
+ (interval-center y-ext))))))
(define-public (oval-stencil stencil thickness x-padding y-padding)
"Add an oval around @code{stencil}, padded by the padding pair,
producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
- (y-ext (ly:stencil-extent stencil Y))
+ (y-ext (ly:stencil-extent stencil Y))
(x-length (+ (interval-length x-ext) x-padding thickness))
(y-length (+ (interval-length y-ext) y-padding thickness))
(x-radius (* 0.707 x-length) )
(y-radius (* 0.707 y-length) )
- (oval (make-oval-stencil x-radius y-radius thickness #f)))
+ (oval (make-oval-stencil x-radius y-radius thickness #f)))
(ly:stencil-add
stencil
(ly:stencil-translate oval
- (cons
- (interval-center x-ext)
- (interval-center y-ext))))))
+ (cons
+ (interval-center x-ext)
+ (interval-center y-ext))))))
(define-public (ellipse-stencil stencil thickness x-padding y-padding)
"Add an ellipse around @var{stencil}, padded by the padding pair,
producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
- (y-ext (ly:stencil-extent stencil Y))
+ (y-ext (ly:stencil-extent stencil Y))
(x-length (+ (interval-length x-ext) x-padding thickness))
(y-length (+ (interval-length y-ext) y-padding thickness))
;; (aspect-ratio (/ x-length y-length))
(x-radius (* 0.707 x-length) )
(y-radius (* 0.707 y-length) )
- ;; (diameter (max (- (cdr x-ext) (car x-ext))
- ;; (- (cdr y-ext) (car y-ext))))
- ;; radius (+ (/ diameter 2) padding thickness))
- (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
+ ;; (diameter (max (- (cdr x-ext) (car x-ext))
+ ;; (- (cdr y-ext) (car y-ext))))
+ ;; radius (+ (/ diameter 2) padding thickness))
+ (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
(ly:stencil-add
stencil
(ly:stencil-translate ellipse
- (cons
- (interval-center x-ext)
- (interval-center y-ext))))))
+ (cons
+ (interval-center x-ext)
+ (interval-center y-ext))))))
(define-public (rounded-box-stencil stencil thickness padding blot)
- "Add a rounded box around @var{stencil}, producing a new stencil."
+ "Add a rounded box around @var{stencil}, producing a new stencil."
(let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
- (yext (interval-widen (ly:stencil-extent stencil 1) padding))
- (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
- (ideal-blot (min blot (/ min-ext 2)))
- (ideal-thickness (min thickness (/ min-ext 2)))
- (outer (ly:round-filled-box
- (interval-widen xext ideal-thickness)
- (interval-widen yext ideal-thickness)
- ideal-blot))
- (inner (ly:make-stencil (list 'color (x11-color 'white)
- (ly:stencil-expr (ly:round-filled-box
- xext yext (- ideal-blot ideal-thickness)))))))
+ (yext (interval-widen (ly:stencil-extent stencil 1) padding))
+ (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
+ (ideal-blot (min blot (/ min-ext 2)))
+ (ideal-thickness (min thickness (/ min-ext 2)))
+ (outer (ly:round-filled-box
+ (interval-widen xext ideal-thickness)
+ (interval-widen yext ideal-thickness)
+ ideal-blot))
+ (inner (ly:make-stencil (list 'color (x11-color 'white)
+ (ly:stencil-expr (ly:round-filled-box
+ xext yext (- ideal-blot ideal-thickness)))))))
(set! stencil (ly:stencil-add outer inner))
stencil))
(ly:stencil-add
(stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
- white)
+ white)
stencil)
))
with optional arrows of @code{max-size} on start and end controlled by
@var{start?} and @var{end?}."
(lambda (destination max-size)
- (let*
- ((e_x 1+0i)
- (e_y 0+1i)
- (distance (sqrt (+ (* (car destination) (car destination))
- (* (cdr destination) (cdr destination)))))
- (size (min max-size (/ distance 3)))
- (rotate (lambda (z ang)
- (* (make-polar 1 ang)
- z)))
- (complex-to-offset (lambda (z)
- (list (real-part z) (imag-part z))))
-
- (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
- (e_z (/ z-dest (magnitude z-dest)))
- (triangle-points (list
- (* size -1+0.25i)
- 0
- (* size -1-0.25i)))
- (p1s (map (lambda (z)
- (+ z-dest (rotate z (angle z-dest))))
- triangle-points))
- (p2s (map (lambda (z)
- (rotate z (angle (- z-dest))))
- triangle-points))
- (null (cons 0 0))
- (arrow-1
- (ly:make-stencil
- `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
- 0.0
- #t) null null))
- (arrow-2
- (ly:make-stencil
- `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
- 0.0
- #t) null null ) )
- (thickness (min (/ distance 12) 0.1))
- (shorten-line (min (/ distance 3) 0.5))
- (start (complex-to-offset (/ (* e_z shorten-line) 2)))
- (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
-
- (line (ly:make-stencil
- `(draw-line ,thickness
- ,(car start) ,(cadr start)
- ,(car end) ,(cadr end)
- )
- (cons (min 0 (car destination))
- (min 0 (cdr destination)))
- (cons (max 0 (car destination))
- (max 0 (cdr destination)))))
-
- (result
- (ly:stencil-add
+ (let*
+ ((e_x 1+0i)
+ (e_y 0+1i)
+ (distance (sqrt (+ (* (car destination) (car destination))
+ (* (cdr destination) (cdr destination)))))
+ (size (min max-size (/ distance 3)))
+ (rotate (lambda (z ang)
+ (* (make-polar 1 ang)
+ z)))
+ (complex-to-offset (lambda (z)
+ (list (real-part z) (imag-part z))))
+
+ (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
+ (e_z (/ z-dest (magnitude z-dest)))
+ (triangle-points (list
+ (* size -1+0.25i)
+ 0
+ (* size -1-0.25i)))
+ (p1s (map (lambda (z)
+ (+ z-dest (rotate z (angle z-dest))))
+ triangle-points))
+ (p2s (map (lambda (z)
+ (rotate z (angle (- z-dest))))
+ triangle-points))
+ (null (cons 0 0))
+ (arrow-1
+ (ly:make-stencil
+ `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
+ 0.0
+ #t) null null))
+ (arrow-2
+ (ly:make-stencil
+ `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
+ 0.0
+ #t) null null ) )
+ (thickness (min (/ distance 12) 0.1))
+ (shorten-line (min (/ distance 3) 0.5))
+ (start (complex-to-offset (/ (* e_z shorten-line) 2)))
+ (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
+
+ (line (ly:make-stencil
+ `(draw-line ,thickness
+ ,(car start) ,(cadr start)
+ ,(car end) ,(cadr end)
+ )
+ (cons (min 0 (car destination))
+ (min 0 (cdr destination)))
+ (cons (max 0 (car destination))
+ (max 0 (cdr destination)))))
+
+ (result
+ (ly:stencil-add
(if start? arrow-2 empty-stencil)
(if end? arrow-1 empty-stencil)
line)))
- result)))
+ result)))
(define-public dimension-arrows (arrow-stencil-maker #t #t))
(define*-public (annotate-y-interval layout name extent is-length
#:key (color darkblue))
(let ((text-props (cons '((font-size . -3)
- (font-family . typewriter))
- (layout-extract-page-properties layout)))
- (annotation #f))
+ (font-family . typewriter))
+ (layout-extract-page-properties layout)))
+ (annotation #f))
(define (center-stencil-on-extent stil)
(ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
(cons 0 (interval-center extent))))
;; do something sensible for 0,0 intervals.
(set! extent (interval-widen extent 0.001))
(if (not (interval-sane? extent))
- (set! annotation (interpret-markup
- layout text-props
- (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
- (let ((text-stencil (interpret-markup
- layout text-props
+ (set! annotation (interpret-markup
+ layout text-props
+ (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
+ (let ((text-stencil (interpret-markup
+ layout text-props
(markup #:whiteout #:simple name)))
(dim-stencil (interpret-markup
layout text-props
(ly:format "~$" (interval-length extent)))
(else
(ly:format "(~$,~$)"
- (car extent) (cdr extent)))))))
- (arrows (ly:stencil-translate-axis
- (dimension-arrows (cons 0 (interval-length extent)) 1.0)
- (interval-start extent) Y)))
- (set! annotation
+ (car extent) (cdr extent)))))))
+ (arrows (ly:stencil-translate-axis
+ (dimension-arrows (cons 0 (interval-length extent)) 1.0)
+ (interval-start extent) Y)))
+ (set! annotation
(center-stencil-on-extent text-stencil))
- (set! annotation
- (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
- (set! annotation
- (ly:stencil-combine-at-edge annotation X LEFT
+ (set! annotation
+ (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
+ (set! annotation
+ (ly:stencil-combine-at-edge annotation X LEFT
(center-stencil-on-extent dim-stencil)
0.5))
- (set! annotation
- (stencil-with-color annotation color))))
+ (set! annotation
+ (stencil-with-color annotation color))))
annotation))
;; TODO: figure out how to annotate padding nicely
;; TODO: emphasize either padding or min-dist depending on which constraint was active
(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y
- #:key (base-color blue))
- (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
- (space (get-spacing-var 'basic-distance))
- (padding (get-spacing-var 'padding))
- (min-dist (get-spacing-var 'minimum-distance))
- (contrast-color (append (cdr base-color) (list (car base-color))))
- (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
- (min-dist-color (if min-dist-blocks contrast-color base-color))
- (basic-annotation (annotate-y-interval layout
- "basic-dist"
- (cons (- start-Y-offset space) start-Y-offset)
- #t
- #:color (map (lambda (x) (* x 0.25)) base-color)))
- (min-annotation (annotate-y-interval layout
- "min-dist"
- (cons (- start-Y-offset min-dist) start-Y-offset)
- #t
- #:color min-dist-color))
- (extra-annotation (annotate-y-interval layout
- "extra dist"
- (cons next-staff-Y (- start-Y-offset min-dist))
- #t
- #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
+ #:key (base-color blue))
+ (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
+ (space (get-spacing-var 'basic-distance))
+ (padding (get-spacing-var 'padding))
+ (min-dist (get-spacing-var 'minimum-distance))
+ (contrast-color (append (cdr base-color) (list (car base-color))))
+ (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
+ (min-dist-color (if min-dist-blocks contrast-color base-color))
+ (basic-annotation (annotate-y-interval layout
+ "basic-dist"
+ (cons (- start-Y-offset space) start-Y-offset)
+ #t
+ #:color (map (lambda (x) (* x 0.25)) base-color)))
+ (min-annotation (annotate-y-interval layout
+ "min-dist"
+ (cons (- start-Y-offset min-dist) start-Y-offset)
+ #t
+ #:color min-dist-color))
+ (extra-annotation (annotate-y-interval layout
+ "extra dist"
+ (cons next-staff-Y (- start-Y-offset min-dist))
+ #t
+ #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
(stack-stencils X RIGHT 0.0
- (list
- basic-annotation
- (if min-dist-blocks
- min-annotation
- (ly:stencil-add min-annotation extra-annotation))))))
+ (list
+ basic-annotation
+ (if min-dist-blocks
+ min-annotation
+ (ly:stencil-add min-annotation extra-annotation))))))
(define-public (eps-file->stencil axis size file-name)
(let*
((contents (ly:gulp-file file-name))
(bbox (get-postscript-bbox (car (string-split contents #\nul))))
(bbox-size (if (= axis X)
- (- (list-ref bbox 2) (list-ref bbox 0))
- (- (list-ref bbox 3) (list-ref bbox 1))
- ))
+ (- (list-ref bbox 2) (list-ref bbox 0))
+ (- (list-ref bbox 3) (list-ref bbox 1))
+ ))
(factor (if (< 0 bbox-size)
- (exact->inexact (/ size bbox-size))
- 0))
+ (exact->inexact (/ size bbox-size))
+ 0))
(scaled-bbox
- (map (lambda (x) (* factor x)) bbox))
+ (map (lambda (x) (* factor x)) bbox))
;; We need to shift the whole eps to (0,0), otherwise it will appear
;; displaced in lilypond (displacement will depend on the scaling!)
(translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
(clip-rect-string (ly:format
- "~a ~a ~a ~a rectclip"
- (list-ref bbox 0)
- (list-ref bbox 1)
- (- (list-ref bbox 2) (list-ref bbox 0))
- (- (list-ref bbox 3) (list-ref bbox 1)))))
+ "~a ~a ~a ~a rectclip"
+ (list-ref bbox 0)
+ (list-ref bbox 1)
+ (- (list-ref bbox 2) (list-ref bbox 0))
+ (- (list-ref bbox 3) (list-ref bbox 1)))))
(if bbox
- (ly:make-stencil
- (list
- 'embedded-ps
- (string-append
- (ly:format
- "
+ (ly:make-stencil
+ (list
+ 'embedded-ps
+ (string-append
+ (ly:format
+ "
gsave
currentpoint translate
BeginEPSF
%%BeginDocument: ~a
" factor translate-string clip-rect-string
- file-name
- )
- contents
- "%%EndDocument
+file-name
+)
+ contents
+ "%%EndDocument
EndEPSF
grestore
"))
- ;; Stencil starts at (0,0), since we have shifted the eps, and its
+ ;; Stencil starts at (0,0), since we have shifted the eps, and its
;; size is exactly the size of the scaled bounding box
- (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
- (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
+ (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
+ (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
- (ly:make-stencil "" '(0 . 0) '(0 . 0)))
+ (ly:make-stencil "" '(0 . 0) '(0 . 0)))
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (write-system-signatures basename paper-systems count)
(if (pair? paper-systems)
(begin
- (let*
- ((outname (simple-format #f "~a-~a.signature" basename count)) )
+ (let*
+ ((outname (simple-format #f "~a-~a.signature" basename count)) )
- (ly:message "Writing ~a" outname)
- (write-system-signature outname (car paper-systems))
- (write-system-signatures basename (cdr paper-systems) (1+ count))))))
+ (ly:message "Writing ~a" outname)
+ (write-system-signature outname (car paper-systems))
+ (write-system-signatures basename (cdr paper-systems) (1+ count))))))
(use-modules (scm paper-system))
(define-public (write-system-signature filename paper-system)
((float? expr) #f)
((ly:font-metric? expr) (ly:font-name expr))
((pair? expr) (cons (strip-floats (car expr))
- (strip-floats (cdr expr))))
+ (strip-floats (cdr expr))))
(else expr)))
(define (fold-false-pairs expr)
"Try to remove lists of #f as much as possible."
(if (pair? expr)
- (let*
- ((first (car expr))
- (rest (fold-false-pairs (cdr expr))))
+ (let*
+ ((first (car expr))
+ (rest (fold-false-pairs (cdr expr))))
- (if first
- (cons (fold-false-pairs first) rest)
- rest))
- expr))
+ (if first
+ (cons (fold-false-pairs first) rest)
+ rest))
+ expr))
(define (raw-string expr)
"escape quotes and slashes for python consumption"
(define (raw-pair expr)
(simple-format #f "~a ~a"
- (car expr) (cdr expr)))
+ (car expr) (cdr expr)))
(define (found-grob expr)
(let*
- ((grob (car expr))
- (rest (cdr expr))
- (collected '())
- (cause (event-cause grob))
- (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
- (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
-
- ;; todo: use stencil extent if available.
- (x-ext (ly:grob-extent grob system-grob X))
- (y-ext (ly:grob-extent grob system-grob Y))
- (expression-skeleton
- (if compare-expressions
- (interpret-for-signature
- #f (lambda (e)
- (set! collected (cons e collected)))
- rest)
- "")))
+ ((grob (car expr))
+ (rest (cdr expr))
+ (collected '())
+ (cause (event-cause grob))
+ (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
+ (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
+
+ ;; todo: use stencil extent if available.
+ (x-ext (ly:grob-extent grob system-grob X))
+ (y-ext (ly:grob-extent grob system-grob Y))
+ (expression-skeleton
+ (if compare-expressions
+ (interpret-for-signature
+ #f (lambda (e)
+ (set! collected (cons e collected)))
+ rest)
+ "")))
(simple-format output
- "~a@~a@~a@~a@~a\n"
- (cdr (assq 'name (ly:grob-property grob 'meta) ))
- (raw-string location)
- (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
- (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
- (raw-string collected))
+ "~a@~a@~a@~a@~a\n"
+ (cdr (assq 'name (ly:grob-property grob 'meta) ))
+ (raw-string location)
+ (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
+ (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
+ (raw-string collected))
))
(define (interpret-for-signature escape collect expr)
(define (interpret expr)
(let*
- ((head (if (pair? expr)
- (car expr)
- #f)))
-
- (cond
- ((eq? head 'grob-cause) (escape (cdr expr)))
- ((eq? head 'color) (interpret (caddr expr)))
- ((eq? head 'rotate-stencil) (interpret (caddr expr)))
- ((eq? head 'translate-stencil) (interpret (caddr expr)))
- ((eq? head 'combine-stencil)
- (for-each (lambda (e) (interpret e)) (cdr expr)))
- (else
- (collect (fold-false-pairs (strip-floats expr))))
-
- )))
+ ((head (if (pair? expr)
+ (car expr)
+ #f)))
+
+ (cond
+ ((eq? head 'grob-cause) (escape (cdr expr)))
+ ((eq? head 'color) (interpret (caddr expr)))
+ ((eq? head 'rotate-stencil) (interpret (caddr expr)))
+ ((eq? head 'translate-stencil) (interpret (caddr expr)))
+ ((eq? head 'combine-stencil)
+ (for-each (lambda (e) (interpret e)) (cdr expr)))
+ (else
+ (collect (fold-false-pairs (strip-floats expr))))
+
+ )))
(interpret expr))
(if (ly:grob? system-grob)
(begin
- (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
- output)
- (interpret-for-signature found-grob (lambda (x) #f)
- (ly:stencil-expr
- (paper-system-stencil paper-system)))))
+ (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
+ output)
+ (interpret-for-signature found-grob (lambda (x) #f)
+ (ly:stencil-expr
+ (paper-system-stencil paper-system)))))
;; should be superfluous, but leaking "too many open files"?
(close-port output))
-
;; define sans serif-style tab-Clefs as a markup:
(define-markup-command (customTabClef
- layout props num-strings staff-space)
+ layout props num-strings staff-space)
(integer? number?)
#:category music
"Draw a tab clef sans-serif style."
;; if it is "moderntab", we'll draw it
(let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
(line-count (if (ly:grob? staff-symbol)
- (ly:grob-property staff-symbol 'line-count)
- 0))
+ (ly:grob-property staff-symbol 'line-count)
+ 0))
(staff-space (ly:staff-symbol-staff-space grob)))
(grob-interpret-markup grob (make-customTabClef-markup line-count
;; tab note head is visible
(if tab-note-head-parenthesized
(begin
- (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
+ (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
(ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
;; tab note head is invisible
- (ly:grob-set-property! tied-tab-note-head 'transparent #t)))
+ (ly:grob-set-property! tied-tab-note-head 'transparent #t)))
;; tie is not split
(ly:grob-set-property! tied-tab-note-head 'transparent #t)))))
(tab-note-head-visible (assoc-get 'note-head-visible repeat-tied-properties #t))
(tab-note-head-parenthesized (assoc-get 'parenthesize repeat-tied-properties #t)))
- (if tab-note-head-visible
- ;; tab note head is visible
- (if tab-note-head-parenthesized
- (begin
- (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
- (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
- ;; tab note head is invisible
- (ly:grob-set-property! tied-tab-note-head 'transparent #t))))))
+ (if tab-note-head-visible
+ ;; tab note head is visible
+ (if tab-note-head-parenthesized
+ (begin
+ (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t)
+ (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print)))
+ ;; tab note head is invisible
+ (ly:grob-set-property! tied-tab-note-head 'transparent #t))))))
;; the slurs should not be too far apart from the corresponding fret number, so
;; we move the slur towards the TabNoteHeads; moreover, if the left fret number is
(* staff-space
(ly:grob-property grob 'direction)
0.35))))
- control-points)))
+ control-points)))
(ly:grob-set-property! grob 'control-points new-control-points)
(ly:slur::print grob)))
(define (is-harmonic? grob)
(let ((arts (ly:event-property (event-cause grob) 'articulations)))
(or (pair? (filter (lambda (a)
- (ly:in-event-class? a 'harmonic-event))
- arts))
- (eq? (ly:grob-property grob 'style) 'harmonic))))
+ (ly:in-event-class? a 'harmonic-event))
+ arts))
+ (eq? (ly:grob-property grob 'style) 'harmonic))))
(let* ((cautionary (ly:grob-property grob 'display-cautionary #f))
- (details (ly:grob-property grob 'details '()))
- (harmonic-props (assoc-get 'harmonic-properties details '()))
- (harmonic-angularity (assoc-get 'angularity harmonic-props 2))
- (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075))
- (harmonic-padding (assoc-get 'padding harmonic-props 0))
- (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil))
- (harmonic-width (assoc-get 'width harmonic-props 0.25))
- (cautionary-props (assoc-get 'cautionary-properties details '()))
- (cautionary-angularity (assoc-get 'angularity cautionary-props 2))
- (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075))
- (cautionary-padding (assoc-get 'padding cautionary-props 0))
- (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil))
- (cautionary-width (assoc-get 'width cautionary-props 0.25))
+ (details (ly:grob-property grob 'details '()))
+ (harmonic-props (assoc-get 'harmonic-properties details '()))
+ (harmonic-angularity (assoc-get 'angularity harmonic-props 2))
+ (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075))
+ (harmonic-padding (assoc-get 'padding harmonic-props 0))
+ (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil))
+ (harmonic-width (assoc-get 'width harmonic-props 0.25))
+ (cautionary-props (assoc-get 'cautionary-properties details '()))
+ (cautionary-angularity (assoc-get 'angularity cautionary-props 2))
+ (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075))
+ (cautionary-padding (assoc-get 'padding cautionary-props 0))
+ (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil))
+ (cautionary-width (assoc-get 'width cautionary-props 0.25))
(output-grob (ly:text-interface::print grob))
- (ref-grob (grob-interpret-markup grob "8"))
- (offset-factor (assoc-get 'head-offset details 3/5))
- (column-offset (* offset-factor
- (interval-length
- (ly:stencil-extent
- (grob-interpret-markup grob "8")
- X)))))
+ (ref-grob (grob-interpret-markup grob "8"))
+ (offset-factor (assoc-get 'head-offset details 3/5))
+ (column-offset (* offset-factor
+ (interval-length
+ (ly:stencil-extent
+ (grob-interpret-markup grob "8")
+ X)))))
(if (is-harmonic? grob)
(set! output-grob (harmonic-proc output-grob
- harmonic-half-thick
- harmonic-width
- harmonic-angularity
- harmonic-padding)))
+ harmonic-half-thick
+ harmonic-width
+ harmonic-angularity
+ harmonic-padding)))
(if cautionary
(set! output-grob (cautionary-proc output-grob
- cautionary-half-thick
- cautionary-width
- cautionary-angularity
- cautionary-padding)))
+ cautionary-half-thick
+ cautionary-width
+ cautionary-angularity
+ cautionary-padding)))
(ly:stencil-translate-axis (centered-stencil output-grob)
- column-offset
- X)))
+ column-offset
+ X)))
;; Harmonic definitions
;; According to the arithmetic sum, the position of m/n is at 1/2*(n-2)(n-1)+(m-1)
;; if we start counting from zero
(vector 12
- 7 19
- 5 12 24
- 4 9 16 28
- 3 7 12 19 31
- 2.7 5.8 9.7 14.7 21.7 33.7
- 2.3 5 8 12 17 24 36
- 2 4.4 7 10 14 19 26 38 ))
+ 7 19
+ 5 12 24
+ 4 9 16 28
+ 3 7 12 19 31
+ 2.7 5.8 9.7 14.7 21.7 33.7
+ 2.3 5 8 12 17 24 36
+ 2 4.4 7 10 14 19 26 38 ))
(define partial-pitch
(vector '(0 0 0)
(- den 1)
1/2)
nom -1)))
- (number->string (vector-ref node-positions index))))
+ (number->string (vector-ref node-positions index))))
(define-public (ratio->pitch ratio)
"Calculate a pitch given @var{ratio} for the harmonic."
(let* ((partial (1- (denominator ratio)))
(pitch (vector-ref partial-pitch partial)))
- (ly:make-pitch (first pitch)
- (second pitch)
- (third pitch))))
+ (ly:make-pitch (first pitch)
+ (second pitch)
+ (third pitch))))
(define-public (fret->pitch fret)
"Calculate a pitch given @var{fret} for the harmonic."
(let* ((partial (assoc-get fret fret-partials 0))
(pitch (vector-ref partial-pitch partial)))
- (ly:make-pitch (first pitch)
- (second pitch)
- (third pitch))))
+ (ly:make-pitch (first pitch)
+ (second pitch)
+ (third pitch))))
(define-public (calc-harmonic-pitch pitch music)
"Calculate the harmonic pitches in @var{music} given
(e (ly:music-property music 'element))
(p (ly:music-property music 'pitch)))
(cond
- ((pair? es)
- (ly:music-set-property! music 'elements
- (map (lambda (x) (calc-harmonic-pitch pitch x)) es)))
- ((ly:music? e)
- (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e)))
- ((ly:pitch? p)
- (begin
- (set! p (ly:pitch-transpose p pitch))
- (ly:music-set-property! music 'pitch p))))
+ ((pair? es)
+ (ly:music-set-property! music 'elements
+ (map (lambda (x) (calc-harmonic-pitch pitch x)) es)))
+ ((ly:music? e)
+ (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e)))
+ ((ly:pitch? p)
+ (begin
+ (set! p (ly:pitch-transpose p pitch))
+ (ly:music-set-property! music 'pitch p))))
music))
(define-public (make-harmonic mus)
"Convert music variable @var{mus} to harmonics."
(let ((elts (ly:music-property mus 'elements))
(elt (ly:music-property mus 'element)))
- (cond
- ((pair? elts)
- (map make-harmonic elts))
- ((ly:music? elt)
- (make-harmonic elt))
- ((music-is-of-type? mus 'note-event)
- (set! (ly:music-property mus 'articulations)
- (append
- (ly:music-property mus 'articulations)
- (list (make-music 'HarmonicEvent))))))
- mus))
+ (cond
+ ((pair? elts)
+ (map make-harmonic elts))
+ ((ly:music? elt)
+ (make-harmonic elt))
+ ((music-is-of-type? mus 'note-event)
+ (set! (ly:music-property mus 'articulations)
+ (append
+ (ly:music-property mus 'articulations)
+ (list (make-music 'HarmonicEvent))))))
+ mus))
(define-public (internal-add-text-replacements props alist)
(let* ((dummy-replacements (chain-assoc-get 'replacement-alist props '()))
(new-replacements
- (append dummy-replacements alist)))
+ (append dummy-replacements alist)))
(prepend-alist-chain 'replacement-alist new-replacements props)))
;; in 2/2 time:
;; use defaults, but end beams with 32nd notes each 1 4 beat
((2 . 2) .
- ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8))))))))
+ ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8))))))))
;; in 2/4, 2/8 and 2/16 time:
;; use defaults, so no entries are necessary
;; use defaults, but end beams with 32nd notes and higher each 1 4 beat
((3 . 2) .
- ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8))))))))
+ ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8))))))))
;; in 3 4 time:
;; use defaults, but combine all beats into a unit if possible
;; in order to avoid beaming every beam type for the entire measure, we set
;; triplets back to every beat.
((3 . 4) .
- ((beamExceptions . ((end . (((1 . 8) . (6)) ;1/8 note whole measure
- ((1 . 12) . (3 3 3)))))))) ;Anything shorter by beat
+ ((beamExceptions . ((end . (((1 . 8) . (6)) ;1/8 note whole measure
+ ((1 . 12) . (3 3 3)))))))) ;Anything shorter by beat
;; in 3 8 time:
;; beam entire measure together
;; in 4 2 time:
;; use defaults, but end beams with 16th notes or finer each 1 4 beat
((4 . 2) .
- ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4 4 4))))))))
+ ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4 4 4))))))))
;; in 4 4 (common) time:
;; use defaults, but combine beats 1,2 and 3,4 if only 8th notes
;; ly/engraver-init.ly where the default time signature is set
;; are set
((4 . 4) .
- ((beamExceptions . ((end . (((1 . 8) . (4 4)) ; 1/8 notes half measure
- ((1 . 12) . (3 3 3 3)))))))) ;Anything shorter by beat
+ ((beamExceptions . ((end . (((1 . 8) . (4 4)) ; 1/8 notes half measure
+ ((1 . 12) . (3 3 3 3)))))))) ;Anything shorter by beat
;; in 4/8 time:
;; combine beats 1 and 2, so beam in 2
;; in 6 4 time:
;; use defaults, but end beams with 32nd or finer each 1/4 beat
((6 . 4) .
- ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4))))))))
+ ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4))))))))
;; in 6 8 time:
;; use defaults, so no entries necessary
;; in 9 4 time:
;; use defaults, but end beams with 32nd or finer each 1 4 beat
((9 . 4) .
- ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8))))))))
+ ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8))))))))
;; in 9 8 time
;; use defaults, so no entries necessary
;; in 12 4 time:
;; use defaults, but end beams with 32nd or finer notes each 1 4 beat
((12 . 4) .
- ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8 8 8 8 8))))))))
+ ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8 8 8 8 8))))))))
;; in 12 8 time:
;; use defaults, so no entries necessary
;; in 5 8 time:
;; default: group (3 2)
((5 . 8) .
- ((beatStructure . (3 2))))
+ ((beatStructure . (3 2))))
;; in 8 8 time:
;; default: group (3 3 2)
((8 . 8) .
- ((beatStructure . (3 3 2))))
+ ((beatStructure . (3 3 2))))
)) ; end of alist definition
"Get setting @code{my-symbol} for @code{time-signature} from
@code{time-signature-settings}."
(let ((my-time-signature-settings
- (assoc-get time-signature time-signature-settings '())))
- (assoc-get my-symbol my-time-signature-settings '())))
+ (assoc-get time-signature time-signature-settings '())))
+ (assoc-get my-symbol my-time-signature-settings '())))
(define-public (make-setting base-fraction
beat-structure
beam-exceptions)
(list
- (cons 'baseMoment (if (pair? base-fraction)
- (/ (car base-fraction) (cdr base-fraction))
- base-fraction))
- (cons 'beatStructure beat-structure)
- (cons 'beamExceptions beam-exceptions)))
+ (cons 'baseMoment (if (pair? base-fraction)
+ (/ (car base-fraction) (cdr base-fraction))
+ base-fraction))
+ (cons 'beatStructure beat-structure)
+ (cons 'beamExceptions beam-exceptions)))
(define-public (base-length time-signature time-signature-settings)
"Get @code{baseMoment} rational value for @var{time-signature} from
@var{time-signature-settings}."
- (let ((return-value (get-setting 'baseMoment
- time-signature
- time-signature-settings)))
- (if (null? return-value)
- (/ (cdr time-signature))
- return-value)))
+ (let ((return-value (get-setting 'baseMoment
+ time-signature
+ time-signature-settings)))
+ (if (null? return-value)
+ (/ (cdr time-signature))
+ return-value)))
(define-public (beat-structure base-length time-signature time-signature-settings)
"Get @code{beatStructure} value in @var{base-length} units
(define-public (beam-exceptions time-signature time-signature-settings)
"Get @code{beamExceptions} value for @var{time-signature} from
@var{time-signature-settings}."
- (get-setting 'beamExceptions time-signature time-signature-settings))
+ (get-setting 'beamExceptions time-signature time-signature-settings))
;;; Functions for overriding time-signature settings
"Like the C++ code that executes \\override, but without type
checking."
(begin
- (ly:context-set-property!
- context
- property
- (cons (cons setting value) (ly:context-property context property)))))
+ (ly:context-set-property!
+ context
+ property
+ (cons (cons setting value) (ly:context-property context property)))))
(define (revert-property-setting context property setting)
"Like the C++ code that executes \revert, but without type
"Count the number of entries in alist with a key of
ENTRY-KEY."
(cond
- ((null? alist) 0)
- ((equal? (caar alist) entry-key)
- (+ 1 (entry-count (cdr alist) entry-key)))
- (else (entry-count (cdr alist) entry-key))))
+ ((null? alist) 0)
+ ((equal? (caar alist) entry-key)
+ (+ 1 (entry-count (cdr alist) entry-key)))
+ (else (entry-count (cdr alist) entry-key))))
(define (revert-member alist entry-key)
"Return ALIST, with the first entry having a key of
ENTRY-KEY removed. ALIST is not modified, instead
a fresh copy of the list-head is made."
(cond
- ((null? alist) '())
- ((equal? (caar alist) entry-key) (cdr alist))
- (else (cons (car alist)
- (revert-member (cdr alist) entry-key)))))
+ ((null? alist) '())
+ ((equal? (caar alist) entry-key) (cdr alist))
+ (else (cons (car alist)
+ (revert-member (cdr alist) entry-key)))))
;; body of revert-property-setting
(let ((current-value (ly:context-property context property)))
(if (> (entry-count current-value setting) 0)
(ly:context-set-property!
- context
- property
- (revert-member current-value setting)))))
+ context
+ property
+ (revert-member current-value setting)))))
(define-public (override-time-signature-setting time-signature setting)
"Override the time signature settings for the context in
@var{time-signature}, with the new setting alist @var{setting}."
- (context-spec-music
- (make-apply-context
- (lambda (c) (override-property-setting
- c
- 'timeSignatureSettings
- time-signature
- setting)))
- 'Timing))
+ (context-spec-music
+ (make-apply-context
+ (lambda (c) (override-property-setting
+ c
+ 'timeSignatureSettings
+ time-signature
+ setting)))
+ 'Timing))
(define-public (revert-time-signature-setting time-signature)
(context-spec-music
- (make-apply-context
- (lambda (c)
- (revert-property-setting
- c
- 'timeSignatureSettings
- time-signature)))
- 'Timing))
+ (make-apply-context
+ (lambda (c)
+ (revert-property-setting
+ c
+ 'timeSignatureSettings
+ time-signature)))
+ 'Timing))
(den (car revargs))
(nums (reverse (cdr revargs))))
(make-override-markup '(baseline-skip . 0)
- (make-number-markup
- (make-left-column-markup
- (list (make-center-column-markup
- (list (make-line-markup (insert-markups nums "+"))
- den))))))))
+ (make-number-markup
+ (make-left-column-markup
+ (list (make-center-column-markup
+ (list (make-line-markup (insert-markups nums "+"))
+ den))))))))
(define (format-complex-compound-time time-sig)
(make-override-markup '(baseline-skip . 0)
- (make-number-markup
- (make-line-markup
- (insert-markups (map format-time-fraction time-sig)
- (make-vcenter-markup "+"))))))
+ (make-number-markup
+ (make-line-markup
+ (insert-markups (map format-time-fraction time-sig)
+ (make-vcenter-markup "+"))))))
(define-public (format-compound-time time-sig)
(cond
- ((not (pair? time-sig)) (null-markup))
- ((pair? (car time-sig)) (format-complex-compound-time time-sig))
- (else (format-time-fraction time-sig))))
+ ((not (pair? time-sig)) (null-markup))
+ ((pair? (car time-sig)) (format-complex-compound-time time-sig))
+ (else (format-time-fraction time-sig))))
;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(define-public (calculate-compound-measure-length time-sig)
(cond
- ((not (pair? time-sig)) (ly:make-moment 4 4))
- ((pair? (car time-sig)) (calculate-complex-compound-time time-sig))
- (else (calculate-time-fraction time-sig))))
+ ((not (pair? time-sig)) (ly:make-moment 4 4))
+ ((pair? (car time-sig)) (calculate-complex-compound-time time-sig))
+ (else (calculate-time-fraction time-sig))))
;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(define-public (calculate-compound-base-beat time-sig)
(ly:make-moment 1
- (cond
- ((not (pair? time-sig)) 4)
- ((pair? (car time-sig)) (calculate-compound-base-beat-full time-sig))
- (else (calculate-compound-base-beat-full (list time-sig))))))
+ (cond
+ ((not (pair? time-sig)) 4)
+ ((pair? (car time-sig)) (calculate-compound-base-beat-full time-sig))
+ (else (calculate-compound-base-beat-full (list time-sig))))))
;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(define-public (calculate-compound-beat-grouping time-sig)
(cond
- ((not (pair? time-sig)) '(2 . 2))
- ((pair? (car time-sig)) (beat-grouping-internal time-sig))
- (else (beat-grouping-internal (list time-sig)))))
+ ((not (pair? time-sig)) '(2 . 2))
+ ((pair? (car time-sig)) (beat-grouping-internal time-sig))
+ (else (beat-grouping-internal (list time-sig)))))
(define-public (layout-extract-page-properties layout)
(list (append `((line-width . ,(ly:paper-get-number
- layout 'line-width)))
- (ly:output-def-lookup layout 'text-font-defaults))))
+ layout 'line-width)))
+ (ly:output-def-lookup layout 'text-font-defaults))))
;;;;;;;;;;;;;;;;;;
and interpret them as markup. The @var{props} argument will include
variables set in @var{scopes} and @code{page:is-bookpart-last-page},
@code{page:is-last-bookpart}, @code{page:page-number-string}, and
-@code{page:page-number}."
+@code{page:page-number}."
(define (get sym)
(ly:output-def-lookup layout sym))
(define (interpret-in-page-env potential-markup)
(if (markup? potential-markup)
- (let* ((alists (map ly:module->alist scopes))
- (prefixed-alists
- (map (lambda (alist)
- (map (lambda (entry)
- (cons
- (string->symbol
- (string-append
- "header:"
- (symbol->string (car entry))))
- (cdr entry)))
- alist))
- alists))
- (pgnum-alist
- (list
- (cons 'header:tagline
- (ly:modules-lookup scopes 'tagline
- (ly:output-def-lookup layout 'tagline)))
- (cons 'page:is-last-bookpart is-last-bookpart)
- (cons 'page:is-bookpart-last-page is-bookpart-last-page)
- (cons 'page:page-number-string
- (number->string page-number))
- (cons 'page:page-number page-number)))
- (props (append
- (list pgnum-alist)
- prefixed-alists
- (layout-extract-page-properties layout))))
- (interpret-markup layout props potential-markup))
+ (let* ((alists (map ly:module->alist scopes))
+ (prefixed-alists
+ (map (lambda (alist)
+ (map (lambda (entry)
+ (cons
+ (string->symbol
+ (string-append
+ "header:"
+ (symbol->string (car entry))))
+ (cdr entry)))
+ alist))
+ alists))
+ (pgnum-alist
+ (list
+ (cons 'header:tagline
+ (ly:modules-lookup scopes 'tagline
+ (ly:output-def-lookup layout 'tagline)))
+ (cons 'page:is-last-bookpart is-last-bookpart)
+ (cons 'page:is-bookpart-last-page is-bookpart-last-page)
+ (cons 'page:page-number-string
+ (number->string page-number))
+ (cons 'page:page-number page-number)))
+ (props (append
+ (list pgnum-alist)
+ prefixed-alists
+ (layout-extract-page-properties layout))))
+ (interpret-markup layout props potential-markup))
- empty-stencil))
+ empty-stencil))
(interpret-in-page-env
(if (and (even? page-number)
- (markup? (get what-even)))
+ (markup? (get what-even)))
(get what-even)
(get what-odd))))
"Read variables @var{what} from @var{scopes}, and interpret it as markup.
The @var{props} argument will include variables set in @var{scopes} (prefixed
with `header:'."
-
+
(define (get sym)
(let ((x (ly:modules-lookup scopes sym)))
(if (markup? x) x #f)))
(let* ((alists (map ly:module->alist scopes))
- (prefixed-alist
- (map (lambda (alist)
- (map (lambda (entry)
- (cons
- (string->symbol
- (string-append
- "header:"
- (symbol->string (car entry))))
- (cdr entry)))
- alist))
- alists))
- (props (append prefixed-alist
- (layout-extract-page-properties layout)))
+ (prefixed-alist
+ (map (lambda (alist)
+ (map (lambda (entry)
+ (cons
+ (string->symbol
+ (string-append
+ "header:"
+ (symbol->string (car entry))))
+ (cdr entry)))
+ alist))
+ alists))
+ (props (append prefixed-alist
+ (layout-extract-page-properties layout)))
- (markup (ly:output-def-lookup layout what)))
+ (markup (ly:output-def-lookup layout what)))
(if (markup? markup)
- (interpret-markup layout props markup)
+ (interpret-markup layout props markup)
empty-stencil)))
(define-module (scm to-xml))
(use-modules (ice-9 regex)
- (srfi srfi-1)
- (lily)
- (oop goops))
+ (srfi srfi-1)
+ (lily)
+ (oop goops))
"
Todo: this is a quick hack; it makes more sense to define a GOOPS
(name #:init-value "" #:accessor node-name #:init-keyword #:name)
(value #:init-value "" #:accessor node-value #:init-keyword #:value)
(attributes #:init-value '()
- #:accessor node-attributes
- #:init-keyword #:attributes)
+ #:accessor node-attributes
+ #:init-keyword #:attributes)
(children #:init-value '()
- #:accessor node-children
- #:init-keyword #:children))
+ #:accessor node-children
+ #:init-keyword #:children))
(define node-names
'((NoteEvent . note)
(string-append
(if xml-name (open-tag xml-name '() '()) "")
(if (equal? (node-value node) "")
- (string-append
- (if xml-name "\n" "")
- (apply string-append (map musicxml-node->string (node-children node))))
- (node-value node))
+ (string-append
+ (if xml-name "\n" "")
+ (apply string-append (map musicxml-node->string (node-children node))))
+ (node-value node))
(if xml-name (close-tag xml-name) "")
(if xml-name "\n" ""))))
(open-tag (node-name node) (node-attributes node) '())
(if (equal? (node-value node) "")
(string-append
- (apply string-append (map xml-node->string (node-children node))))
+ (apply string-append (map xml-node->string (node-children node))))
(node-value node))
"\n"
(close-tag (node-name node))))
#:name 'duration
;; #:value (number->string (ash 1 (ly:duration-log d)))))
#:attributes `((log . ,(ly:duration-log d))
- (dots . ,(ly:duration-dot-count d))
- (numer . ,(car (ly:duration-factor d)))
- (denom . ,(cdr (ly:duration-factor d))))))
+ (dots . ,(ly:duration-dot-count d))
+ (numer . ,(car (ly:duration-factor d)))
+ (denom . ,(cdr (ly:duration-factor d))))))
(define (pitch->xml-node p)
(make <xml-node>
#:name 'pitch
#:attributes `((octave . ,(ly:pitch-octave p))
- (notename . ,(ly:pitch-notename p))
- (alteration . ,(ly:pitch-alteration p)))))
+ (notename . ,(ly:pitch-notename p))
+ (alteration . ,(ly:pitch-alteration p)))))
(define (music->xml-node music)
(let* ((name (ly:music-property music 'name))
- (e (ly:music-property music 'element))
- (es (ly:music-property music 'elements))
- (mprops (ly:music-mutable-properties music))
- (d (ly:music-property music 'duration))
- (p (ly:music-property music 'pitch))
- (ignore-props '(origin elements duration pitch element)))
-
+ (e (ly:music-property music 'element))
+ (es (ly:music-property music 'elements))
+ (mprops (ly:music-mutable-properties music))
+ (d (ly:music-property music 'duration))
+ (p (ly:music-property music 'pitch))
+ (ignore-props '(origin elements duration pitch element)))
+
(make <xml-node>
#:name name
#:children
(if (null? alist)
string
(re-sub (caar alist) (cdar alist)
- (re-sub-alist string (cdr alist)))))
+ (re-sub-alist string (cdr alist)))))
(define xml-entities-alist
'(("\"" . """)
(define (open-tag tag attrs exceptions)
(define (candidate? x)
(not (memq (car x) exceptions)))
-
+
(define (dump-attr sym-val)
(let* ((sym (car sym-val))
- (val (cdr sym-val)))
-
+ (val (cdr sym-val)))
+
(string-append
"\n "
(symbol->string sym)
"=\""
(let ((s (call-with-output-string (lambda (port) (display val port)))))
- (re-sub-alist s xml-entities-alist))
+ (re-sub-alist s xml-entities-alist))
"\"")))
(string-append
;; dtd contains # -- This confuses tex during make doc.
;;
;; (display (dtd-header) port)
-
+
(display (open-tag 'music '((type . score)) '()) port)
(display (xml-node->string (music->xml-node music)) port)
(display (close-tag 'music) port))
;; (display (dtd-header) port)
(define duration->xml-node musicxml-duration->xml-node)
-
+
(display (open-tag 'music '((type . score)) '()) port)
(display (musicxml-node->string (music->xml-node music)) port)
(display (close-tag 'music) port))
-
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; (c) 1998--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
-;;;; Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Jan Nieuwenhuizen <janneke@gnu.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
(cons "" "")))
(text (string-concatenate (list (car delim) oct (cdr delim)))))
- (make-vcenter-markup text)))
+ (make-vcenter-markup text)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (format-metronome-markup event context)
(let ((hide-note (ly:context-property context 'tempoHideNote #f))
- (text (ly:event-property event 'text))
- (dur (ly:event-property event 'tempo-unit))
- (count (ly:event-property event 'metronome-count)))
+ (text (ly:event-property event 'text))
+ (dur (ly:event-property event 'tempo-unit))
+ (count (ly:event-property event 'metronome-count)))
(metronome-markup text dur count hide-note)))
(define-public (metronome-markup text dur count hide-note)
(let* ((note-mark (if (and (not hide-note) (ly:duration? dur))
- (make-smaller-markup
- (make-note-by-number-markup (ly:duration-log dur)
- (ly:duration-dot-count dur)
- 1))
- #f))
- (count-markup (cond ((number? count)
- (if (> count 0)
- (make-simple-markup (number->string count))
- #f))
- ((pair? count)
- (make-concat-markup
- (list
- (make-simple-markup (number->string (car count)))
- (make-simple-markup " ")
- (make-simple-markup "–")
- (make-simple-markup " ")
- (make-simple-markup (number->string (cdr count))))))
- (else #f)))
+ (make-smaller-markup
+ (make-note-by-number-markup (ly:duration-log dur)
+ (ly:duration-dot-count dur)
+ 1))
+ #f))
+ (count-markup (cond ((number? count)
+ (if (> count 0)
+ (make-simple-markup (number->string count))
+ #f))
+ ((pair? count)
+ (make-concat-markup
+ (list
+ (make-simple-markup (number->string (car count)))
+ (make-simple-markup " ")
+ (make-simple-markup "–")
+ (make-simple-markup " ")
+ (make-simple-markup (number->string (cdr count))))))
+ (else #f)))
(note-markup (if (and (not hide-note) count-markup)
- (make-concat-markup
- (list
- (make-general-align-markup Y DOWN note-mark)
- (make-simple-markup " ")
- (make-simple-markup "=")
- (make-simple-markup " ")
- count-markup))
- #f))
+ (make-concat-markup
+ (list
+ (make-general-align-markup Y DOWN note-mark)
+ (make-simple-markup " ")
+ (make-simple-markup "=")
+ (make-simple-markup " ")
+ count-markup))
+ #f))
(text-markup (if (not (null? text))
- (make-bold-markup text)
- #f)))
+ (make-bold-markup text)
+ #f)))
(if text-markup
- (if (and note-markup (not hide-note))
- (make-line-markup (list text-markup
- (make-concat-markup
- (list (make-simple-markup "(")
- note-markup
- (make-simple-markup ")")))))
- (make-line-markup (list text-markup)))
- (if note-markup
- (make-line-markup (list note-markup))
- (make-null-markup)))))
+ (if (and note-markup (not hide-note))
+ (make-line-markup (list text-markup
+ (make-concat-markup
+ (list (make-simple-markup "(")
+ note-markup
+ (make-simple-markup ")")))))
+ (make-line-markup (list text-markup)))
+ (if note-markup
+ (make-line-markup (list note-markup))
+ (make-null-markup)))))
(define-public (format-mark-alphabet mark context)
(make-bold-markup (make-markalphabet-markup (1- mark))))
(define-public (format-mark-barnumbers mark context)
(make-bold-markup (number->string (ly:context-property context
- 'currentBarNumber))))
+ 'currentBarNumber))))
(define-public (format-mark-box-letters mark context)
(make-bold-markup (make-box-markup (make-markletter-markup (1- mark)))))
(define-public (format-mark-box-barnumbers mark context)
(make-bold-markup (make-box-markup
- (number->string (ly:context-property context
- 'currentBarNumber)))))
+ (number->string (ly:context-property context
+ 'currentBarNumber)))))
(define-public (format-mark-circle-barnumbers mark context)
(make-bold-markup (make-circle-markup
- (number->string (ly:context-property context
- 'currentBarNumber)))))
+ (number->string (ly:context-property context
+ 'currentBarNumber)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (format-bass-figure figure event context)
(let* ((fig (ly:event-property event 'figure))
- (fig-markup (if (number? figure)
-
- ;; this is not very elegant, but center-aligning
- ;; all digits is problematic with other markups,
- ;; and shows problems in the (lack of) overshoot
- ;; of feta-alphabet glyphs.
- ((if (<= 10 figure)
- (lambda (y) (make-translate-scaled-markup
- (cons -0.7 0) y))
- identity)
-
- (cond
- ((eq? #t (ly:event-property event 'diminished))
- (markup #:slashed-digit figure))
- ((eq? #t (ly:event-property event 'augmented-slash))
- (markup #:backslashed-digit figure))
- (else (markup #:number (number->string figure 10)))))
- #f))
-
- (alt (ly:event-property event 'alteration))
- (alt-markup
- (if (number? alt)
- (markup
- #:general-align Y DOWN #:fontsize
- (if (not (= alt DOUBLE-SHARP))
- -2 2)
- (alteration->text-accidental-markup alt))
- #f))
-
- (plus-markup (if (eq? #t (ly:event-property event 'augmented))
- (markup #:number "+")
- #f))
-
- (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
- (plus-dir (ly:context-property context 'figuredBassPlusDirection)))
+ (fig-markup (if (number? figure)
+
+ ;; this is not very elegant, but center-aligning
+ ;; all digits is problematic with other markups,
+ ;; and shows problems in the (lack of) overshoot
+ ;; of feta-alphabet glyphs.
+ ((if (<= 10 figure)
+ (lambda (y) (make-translate-scaled-markup
+ (cons -0.7 0) y))
+ identity)
+
+ (cond
+ ((eq? #t (ly:event-property event 'diminished))
+ (markup #:slashed-digit figure))
+ ((eq? #t (ly:event-property event 'augmented-slash))
+ (markup #:backslashed-digit figure))
+ (else (markup #:number (number->string figure 10)))))
+ #f))
+
+ (alt (ly:event-property event 'alteration))
+ (alt-markup
+ (if (number? alt)
+ (markup
+ #:general-align Y DOWN #:fontsize
+ (if (not (= alt DOUBLE-SHARP))
+ -2 2)
+ (alteration->text-accidental-markup alt))
+ #f))
+
+ (plus-markup (if (eq? #t (ly:event-property event 'augmented))
+ (markup #:number "+")
+ #f))
+
+ (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
+ (plus-dir (ly:context-property context 'figuredBassPlusDirection)))
(if (and (not fig-markup) alt-markup)
- (begin
- (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
- (set! alt-markup #f)))
+ (begin
+ (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
+ (set! alt-markup #f)))
;; hmm, how to get figures centered between note, and
;; lone accidentals too?
;; (if (markup? fig-markup)
- ;; (set!
- ;; fig-markup (markup #:translate (cons 1.0 0)
- ;; #:center-align fig-markup)))
+ ;; (set!
+ ;; fig-markup (markup #:translate (cons 1.0 0)
+ ;; #:center-align fig-markup)))
(if alt-markup
- (set! fig-markup
- (markup #:put-adjacent
- X (if (number? alt-dir)
- alt-dir
- LEFT)
- fig-markup
- #:pad-x 0.2 alt-markup)))
+ (set! fig-markup
+ (markup #:put-adjacent
+ X (if (number? alt-dir)
+ alt-dir
+ LEFT)
+ fig-markup
+ #:pad-x 0.2 alt-markup)))
(if plus-markup
- (set! fig-markup
- (if fig-markup
- (markup #:put-adjacent
- X (if (number? plus-dir)
- plus-dir
- LEFT)
- fig-markup
- #:pad-x 0.2 plus-markup)
- plus-markup)))
+ (set! fig-markup
+ (if fig-markup
+ (markup #:put-adjacent
+ X (if (number? plus-dir)
+ plus-dir
+ LEFT)
+ fig-markup
+ #:pad-x 0.2 plus-markup)
+ plus-markup)))
(if (markup? fig-markup)
- (markup #:fontsize -2 fig-markup)
- empty-markup)))
+ (markup #:fontsize -2 fig-markup)
+ empty-markup)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Convert @var{placement-list} into a fretboard @var{grob}."
(let* ((tunings (ly:context-property context 'stringTunings))
- (my-string-count (length tunings))
- (details (ly:grob-property grob 'fret-diagram-details)))
+ (my-string-count (length tunings))
+ (details (ly:grob-property grob 'fret-diagram-details)))
;; Add string-count from string-tunings to fret-diagram-details.
(set! (ly:grob-property grob 'fret-diagram-details)
- (acons 'string-count my-string-count details))
+ (acons 'string-count my-string-count details))
;; Create the dot-placement list for the grob
(set! (ly:grob-property grob 'dot-placement-list) placement-list)))
dot placement entries."
(let* ((placements (list->vector
(map (lambda (x) (list 'mute x))
- (iota string-count 1)))))
+ (iota string-count 1)))))
(for-each (lambda (sf)
- (let* ((string (car sf))
- (fret (cadr sf))
- (finger (caddr sf)))
- (vector-set!
- placements
- (1- string)
- (if (= 0 fret)
- (list 'open string)
- (if finger
- (list 'place-fret string fret finger)
- (list 'place-fret string fret))))))
- string-frets)
+ (let* ((string (car sf))
+ (fret (cadr sf))
+ (finger (caddr sf)))
+ (vector-set!
+ placements
+ (1- string)
+ (if (= 0 fret)
+ (list 'open string)
+ (if finger
+ (list 'place-fret string fret finger)
+ (list 'place-fret string fret))))))
+ string-frets)
(vector->list placements)))
(define (placement-list->string-frets placement-list)
(and (integer? num) (positive? num) num)))
(define (determine-frets-and-strings
- notes
- defined-strings
- defined-fingers
- minimum-fret
- maximum-stretch
- tuning)
+ notes
+ defined-strings
+ defined-fingers
+ minimum-fret
+ maximum-stretch
+ tuning)
"Determine the frets and strings used to play the notes in
@var{notes}, given @var{defined-strings} and @var{defined-fingers}
along with @var{minimum-fret}, @var{maximum-stretch}, and
(define restrain-open-strings (ly:context-property context
- 'restrainOpenStrings
- #f))
+ 'restrainOpenStrings
+ #f))
(define specified-frets '())
(define free-strings (iota (length tuning) 1))
"Get the fingering from @var{ev}. Return @var{#f}
if no fingering is present."
(let* ((articulations (ly:event-property ev 'articulations))
- (finger-found #f))
- (map (lambda (art)
- (let* ((num (ly:event-property art 'digit)))
+ (finger-found #f))
+ (map (lambda (art)
+ (let* ((num (ly:event-property art 'digit)))
- (if (and (ly:in-event-class? art 'fingering-event)
- (number? num)
- (> num 0))
- (set! finger-found num))))
- articulations)
- finger-found))
+ (if (and (ly:in-event-class? art 'fingering-event)
+ (number? num)
+ (> num 0))
+ (set! finger-found num))))
+ articulations)
+ finger-found))
(define (delete-free-string string)
(if (number? string)
- (set! free-strings
- (delete string free-strings))))
+ (set! free-strings
+ (delete string free-strings))))
(define (close-enough fret)
"Decide if @var{fret} is acceptable, given the already used frets."
"Can @var{pitch} be played on @var{string}, given already placed
notes?"
(let* ((fret (calc-fret pitch string tuning)))
- (and (or (and (not restrain-open-strings)
- (zero? fret))
- (>= fret minimum-fret))
- (integer? fret)
- (close-enough fret))))
+ (and (or (and (not restrain-open-strings)
+ (zero? fret))
+ (>= fret minimum-fret))
+ (integer? fret)
+ (close-enough fret))))
(define (open-string string pitch)
"Is @var{pitch} and open-string note on @var{string}, given
the current tuning?"
(let* ((fret (calc-fret pitch string tuning)))
- (zero? fret)))
+ (zero? fret)))
(define (set-fret! pitch-entry string finger)
(let ((this-fret (calc-fret (car pitch-entry)
- string
- tuning)))
- (if (< this-fret 0)
- (ly:warning (_ "Negative fret for pitch ~a on string ~a")
- (car pitch-entry) string)
- (if (not (integer? this-fret))
- (ly:warning (_ "Missing fret for pitch ~a on string ~a")
- (car pitch-entry) string)))
- (delete-free-string string)
+ string
+ tuning)))
+ (if (< this-fret 0)
+ (ly:warning (_ "Negative fret for pitch ~a on string ~a")
+ (car pitch-entry) string)
+ (if (not (integer? this-fret))
+ (ly:warning (_ "Missing fret for pitch ~a on string ~a")
+ (car pitch-entry) string)))
+ (delete-free-string string)
(set! specified-frets (cons this-fret specified-frets))
(list-set! string-fret-fingers
(cdr pitch-entry)
(list-set! string-fret-fingers note-index (list #f #t)))
(define string-fret-fingers
- (map (lambda (string finger)
- (if (null? finger)
- (list string #f)
- (list string #f finger)))
- defined-strings defined-fingers))
+ (map (lambda (string finger)
+ (if (null? finger)
+ (list string #f)
+ (list string #f finger)))
+ defined-strings defined-fingers))
;;; body of determine-frets-and-strings
(let* ((pitches (map note-pitch notes))
;; handle notes with strings assigned and fingering of 0
(for-each
- (lambda (pitch-entry string-fret-finger)
- (let* ((string (list-ref string-fret-finger 0))
- (finger (if (= (length string-fret-finger) 3)
- (list-ref string-fret-finger 2)
- '()))
- (pitch (car pitch-entry))
- (digit (if (null? finger)
- #f
- finger)))
- (if (or (not (null? string))
- (eqv? digit 0))
- (if (eqv? digit 0)
- ;; here we handle fingers of 0 -- open strings
- (let ((fit-string
- (find (lambda (string)
- (open-string string pitch))
- free-strings)))
- (if fit-string
- (set-fret! pitch-entry fit-string #f)
- (ly:warning (_ "No open string for pitch ~a")
- pitch)))
- ;; here we handle assigned strings
- (let ((this-fret
- (calc-fret pitch string tuning))
- (handle-negative
- (ly:context-property context
- 'handleNegativeFrets
- 'recalculate)))
- (cond ((or (and (>= this-fret 0) (integer? this-fret))
- (eq? handle-negative 'include))
- (set-fret! pitch-entry string finger))
- ((eq? handle-negative 'recalculate)
- (begin
- (ly:warning
- (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
- string
- pitch)
- (ly:warning (_ "Ignoring string request and recalculating."))
- (list-set! string-fret-fingers
- (cdr pitch-entry)
- (if (null? finger)
- (list '() #f)
- (list '() #f finger)))))
- ((eq? handle-negative 'ignore)
- (begin
- (ly:warning
- (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
- string
- pitch)
- (ly:warning (_ "Ignoring note in tablature."))
- (kill-note! string-fret-fingers
- (cdr pitch-entry))))))))))
- pitch-alist string-fret-fingers)
- ;; handle notes without strings assigned -- sorted by pitch, so
- ;; we need to use the alist to have the note number available
- (for-each
- (lambda (pitch-entry)
- (let* ((string-fret-finger (list-ref string-fret-fingers
- (cdr pitch-entry)))
- (string (list-ref string-fret-finger 0))
- (finger (if (= (length string-fret-finger) 3)
- (list-ref string-fret-finger 2)
- '()))
- (pitch (car pitch-entry))
- (fit-string
- (find (lambda (string)
- (string-qualifies string pitch))
- free-strings)))
- (if (not (list-ref string-fret-finger 1))
- (if fit-string
- (set-fret! pitch-entry fit-string finger)
- (begin
- (ly:warning (_ "No string for pitch ~a (given frets ~a)")
- pitch
- specified-frets)
- (kill-note! string-fret-fingers
- (cdr pitch-entry)))))))
- (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b)
- (ly:pitch<? (car pitch-entry-b)
- (car pitch-entry-a)))))
- string-fret-fingers)) ;; end of determine-frets-and-strings
+ (lambda (pitch-entry string-fret-finger)
+ (let* ((string (list-ref string-fret-finger 0))
+ (finger (if (= (length string-fret-finger) 3)
+ (list-ref string-fret-finger 2)
+ '()))
+ (pitch (car pitch-entry))
+ (digit (if (null? finger)
+ #f
+ finger)))
+ (if (or (not (null? string))
+ (eqv? digit 0))
+ (if (eqv? digit 0)
+ ;; here we handle fingers of 0 -- open strings
+ (let ((fit-string
+ (find (lambda (string)
+ (open-string string pitch))
+ free-strings)))
+ (if fit-string
+ (set-fret! pitch-entry fit-string #f)
+ (ly:warning (_ "No open string for pitch ~a")
+ pitch)))
+ ;; here we handle assigned strings
+ (let ((this-fret
+ (calc-fret pitch string tuning))
+ (handle-negative
+ (ly:context-property context
+ 'handleNegativeFrets
+ 'recalculate)))
+ (cond ((or (and (>= this-fret 0) (integer? this-fret))
+ (eq? handle-negative 'include))
+ (set-fret! pitch-entry string finger))
+ ((eq? handle-negative 'recalculate)
+ (begin
+ (ly:warning
+ (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
+ string
+ pitch)
+ (ly:warning (_ "Ignoring string request and recalculating."))
+ (list-set! string-fret-fingers
+ (cdr pitch-entry)
+ (if (null? finger)
+ (list '() #f)
+ (list '() #f finger)))))
+ ((eq? handle-negative 'ignore)
+ (begin
+ (ly:warning
+ (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
+ string
+ pitch)
+ (ly:warning (_ "Ignoring note in tablature."))
+ (kill-note! string-fret-fingers
+ (cdr pitch-entry))))))))))
+ pitch-alist string-fret-fingers)
+ ;; handle notes without strings assigned -- sorted by pitch, so
+ ;; we need to use the alist to have the note number available
+ (for-each
+ (lambda (pitch-entry)
+ (let* ((string-fret-finger (list-ref string-fret-fingers
+ (cdr pitch-entry)))
+ (string (list-ref string-fret-finger 0))
+ (finger (if (= (length string-fret-finger) 3)
+ (list-ref string-fret-finger 2)
+ '()))
+ (pitch (car pitch-entry))
+ (fit-string
+ (find (lambda (string)
+ (string-qualifies string pitch))
+ free-strings)))
+ (if (not (list-ref string-fret-finger 1))
+ (if fit-string
+ (set-fret! pitch-entry fit-string finger)
+ (begin
+ (ly:warning (_ "No string for pitch ~a (given frets ~a)")
+ pitch
+ specified-frets)
+ (kill-note! string-fret-fingers
+ (cdr pitch-entry)))))))
+ (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b)
+ (ly:pitch<? (car pitch-entry-b)
+ (car pitch-entry-a)))))
+ string-fret-fingers)) ;; end of determine-frets-and-strings
(define (get-predefined-fretboard predefined-fret-table tuning pitches)
"Search through @var{predefined-fret-table} looking for a predefined
(define (get-fretboard key)
(let ((hash-handle
- (hash-get-handle predefined-fret-table key)))
- (if hash-handle
- (cdr hash-handle) ; return table entry
- '())))
+ (hash-get-handle predefined-fret-table key)))
+ (if hash-handle
+ (cdr hash-handle) ; return table entry
+ '())))
;; body of get-predefined-fretboard
(let ((test-fretboard (get-fretboard (cons tuning pitches))))
(if (not (null? test-fretboard))
- test-fretboard
- (let ((test-fretboard
- (get-fretboard
- (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
- (if (not (null? test-fretboard))
- test-fretboard
- (get-fretboard
- (cons tuning (map (lambda (x) (shift-octave x -1))
- pitches))))))))
+ test-fretboard
+ (let ((test-fretboard
+ (get-fretboard
+ (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
+ (if (not (null? test-fretboard))
+ test-fretboard
+ (get-fretboard
+ (cons tuning (map (lambda (x) (shift-octave x -1))
+ pitches))))))))
;; body of determine-frets
(let* ((predefined-fret-table
- (ly:context-property context 'predefinedDiagramTable))
+ (ly:context-property context 'predefinedDiagramTable))
(tunings (ly:context-property context 'stringTunings))
(string-count (length tunings))
(grob (if (null? rest) '() (car rest)))
- (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
+ (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
(defined-strings (map (lambda (x)
(if (null? x)
x
tunings
pitches)
'())))
- (if (null? predefined-fretboard)
- (let ((string-frets
- (determine-frets-and-strings
- notes
- strings-used
- defined-fingers
- (ly:context-property context 'minimumFret 0)
- (ly:context-property context 'maximumFretStretch 4)
- tunings)))
- (if (null? grob)
- string-frets
- (create-fretboard
- context grob (string-frets->placement-list
- (filter (lambda (entry)
- (car entry))
- string-frets)
- string-count))))
- (if (null? grob)
- (placement-list->string-frets predefined-fretboard)
- (create-fretboard context grob predefined-fretboard)))))
+ (if (null? predefined-fretboard)
+ (let ((string-frets
+ (determine-frets-and-strings
+ notes
+ strings-used
+ defined-fingers
+ (ly:context-property context 'minimumFret 0)
+ (ly:context-property context 'maximumFretStretch 4)
+ tunings)))
+ (if (null? grob)
+ string-frets
+ (create-fretboard
+ context grob (string-frets->placement-list
+ (filter (lambda (entry)
+ (car entry))
+ string-frets)
+ string-count))))
+ (if (null? grob)
+ (placement-list->string-frets predefined-fretboard)
+ (create-fretboard context grob predefined-fretboard)))))
;; The fret letter is taken from 'fretLabels if present
(define-public (fret-letter-tablature-format
context string-number fret-number)
- (let ((labels (ly:context-property context 'fretLabels)))
- (make-vcenter-markup
- (cond
- ((= 0 (length labels))
- (string (integer->char (+ fret-number (char->integer #\a)))))
- ((and (<= 0 fret-number) (< fret-number (length labels)))
- (list-ref labels fret-number))
- (else
- (ly:warning (_ "No label for fret ~a (on string ~a);
+ (let ((labels (ly:context-property context 'fretLabels)))
+ (make-vcenter-markup
+ (cond
+ ((= 0 (length labels))
+ (string (integer->char (+ fret-number (char->integer #\a)))))
+ ((and (<= 0 fret-number) (< fret-number (length labels)))
+ (list-ref labels fret-number))
+ (else
+ (ly:warning (_ "No label for fret ~a (on string ~a);
only ~a fret labels provided")
- fret-number string-number (length labels))
- ".")))))
+ fret-number string-number (length labels))
+ ".")))))
;; Display the fret number as a number
(define-public (fret-number-tablature-format
context string-number fret-number)
(make-vcenter-markup
- (format #f "~a" fret-number)))
+ (format #f "~a" fret-number)))
;; The 5-string banjo has got a extra string, the fifth (duh), which
;; starts at the fifth fret on the neck. Frets on the fifth string
;; We solve this by defining a new fret-number-tablature function:
(define-public (fret-number-tablature-format-banjo
context string-number fret-number)
- (make-vcenter-markup
- (number->string (cond
- ((and (> fret-number 0) (= string-number 5))
- (+ fret-number 5))
- (else fret-number)))))
+ (make-vcenter-markup
+ (number->string (cond
+ ((and (> fret-number 0) (= string-number 5))
+ (+ fret-number 5))
+ (else fret-number)))))
;; Tab note head staff position functions
;;
;; lines
(define-public (tablature-position-on-lines context string-number)
- (let* ((string-tunings (ly:context-property context 'stringTunings))
- (string-count (length string-tunings))
- (string-one-topmost (ly:context-property context 'stringOneTopmost))
- (staff-line (- (* 2 string-number) string-count 1)))
- (if string-one-topmost
- (- staff-line)
- staff-line)))
+ (let* ((string-tunings (ly:context-property context 'stringTunings))
+ (string-count (length string-tunings))
+ (string-one-topmost (ly:context-property context 'stringOneTopmost))
+ (staff-line (- (* 2 string-number) string-count 1)))
+ (if string-one-topmost
+ (- staff-line)
+ staff-line)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bar numbers
(define-public ((set-bar-number-visibility n) tr)
(let ((bn (ly:context-property tr 'currentBarNumber)))
(ly:context-set-property! tr 'barNumberVisibility
- (modulo-bar-number-visible n (modulo bn n)))))
+ (modulo-bar-number-visible n (modulo bn n)))))
(define-public (first-bar-number-invisible barnum mp)
(> barnum 1))
(cons (+ alt-number (- (expt 26 pow) an)) (1- pow))))
(define (make-letter so-far an pow)
(if (< pow 0)
- so-far
- (let ((pos (modulo (quotient an (expt 26 pow)) 26)))
- (make-letter (string-append so-far
- (substring "abcdefghijklmnopqrstuvwxyz"
- pos
- (1+ pos)))
- an
- (1- pow)))))
+ so-far
+ (let ((pos (modulo (quotient an (expt 26 pow)) 26)))
+ (make-letter (string-append so-far
+ (substring "abcdefghijklmnopqrstuvwxyz"
+ pos
+ (1+ pos)))
+ an
+ (1- pow)))))
(let* ((number-and-power (get-number-and-power 0 0))
(begin-measure (= 0 (ly:moment-main-numerator measure-pos)))
(maybe-open-parenthesis (if begin-measure "" "("))
with the subordinate symbols being interfaces."
(let loop ((forms forms))
(if (cheap-list? forms)
- `(list
- ,@(map (lambda (form)
- (if (pair? (car form))
- `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
- `(cons ',(car form) ,(loop (cdr form)))))
- forms))
- forms)))
+ `(list
+ ,@(map (lambda (form)
+ (if (pair? (car form))
+ `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
+ `(cons ',(car form) ,(loop (cdr form)))))
+ forms))
+ forms)))
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-(define x11-color-list
+(define x11-color-list
'((snow 1 0.98039215686274506 0.98039215686274506)
(GhostWhite 0.97254901960784312 0.97254901960784312 1)
(WhiteSmoke 0.96078431372549022 0.96078431372549022 0.96078431372549022)
(define (make-x11-color-handler)
(let
((x11-color-table (make-hash-table 31)))
-
+
(lambda (arg)
- (let*
- ((arg-sym (if (string? arg)
- (if (string-index arg #\ )
- (let
- ((arg-list (string-split (string-capitalize arg) #\ )))
+ (let*
+ ((arg-sym (if (string? arg)
+ (if (string-index arg #\ )
+ (let
+ ((arg-list (string-split (string-capitalize arg) #\ )))
+
+ (string->symbol
+ (let append-all ((x arg-list))
+ (if (null? x)
+ ""
+ (string-append (car x) (append-all (cdr x)))))))
+
+ (string->symbol arg))
+ arg))
+
+ (temp (hashq-ref x11-color-table arg-sym)))
+
+ (if temp
+ temp
+ (let*
+ ((temp-1 (assq-ref x11-color-list arg-sym))
+ (temp (if temp-1 temp-1 '(0 0 0))))
- (string->symbol
- (let append-all ((x arg-list))
- (if (null? x)
- ""
- (string-append (car x) (append-all (cdr x)))))))
-
- (string->symbol arg))
- arg))
-
- (temp (hashq-ref x11-color-table arg-sym)))
-
- (if temp
- temp
- (let*
- ((temp-1 (assq-ref x11-color-list arg-sym))
- (temp (if temp-1 temp-1 '(0 0 0))))
-
- (hashq-create-handle! x11-color-table arg-sym temp)
- temp))))))
+ (hashq-create-handle! x11-color-table arg-sym temp)
+ temp))))))
(define-public x11-color (make-x11-color-handler))
projects / lilypond.git / commitdiff