X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=8edb6586270efe444476505a5cd5871077147419;hb=d3edd18b19979ac9947486af04a002a6118072ff;hp=724165a88f399d9e02d4877f256990bd1763860b;hpb=fbda0de6b70400e8cf9d44cdfaa75051891977d0;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 724165a88f..8edb658627 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -2,8 +2,8 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2006 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; (c) 1998--2009 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys ;; (use-modules (ice-9 optargs)) @@ -16,6 +16,9 @@ (make-procedure-with-setter ly:music-property ly:music-set-property!)) +(define-safe-public (music-is-of-type? mus type) + "Does @code{mus} belong to the music class @code{type}?" + (memq type (ly:music-property mus 'types))) ;; TODO move this (define-public ly:grob-property @@ -71,6 +74,7 @@ First it recurses over the children, then the function is applied to MUSIC. (define-public (display-music music) "Display music, not done with music-map for clarity of presentation." + (display music) (display ": { ") (let ((es (ly:music-property music 'elements)) @@ -109,9 +113,11 @@ For instance, (else ;; scheme arg arg))) (define (inner-markup->make-markup mrkup) - (let ((cmd (proc->command-keyword (car mrkup))) - (args (map transform-arg (cdr mrkup)))) - `(,cmd ,@args))) + (if (string? mrkup) + `(#:simple ,mrkup) + (let ((cmd (proc->command-keyword (car mrkup))) + (args (map transform-arg (cdr mrkup)))) + `(,cmd ,@args)))) ;; body: (if (string? markup-expression) markup-expression @@ -129,11 +135,7 @@ that is, for a music expression, a (make-music ...) form." ',(ly:music-property obj 'name) ,@(apply append (map (lambda (prop) `(',(car prop) - ,(if (and (not (markup? (cdr prop))) - (list? (cdr prop)) - (pair? (cdr prop))) ;; property is a non-empty list - `(list ,@(map music->make-music (cdr prop))) - (music->make-music (cdr prop))))) + ,(music->make-music (cdr prop)))) (remove (lambda (prop) (eqv? (car prop) 'origin)) (ly:music-mutable-properties obj)))))) @@ -163,6 +165,13 @@ that is, for a music expression, a (make-music ...) form." (;; 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))) @@ -177,10 +186,25 @@ Returns `obj'. (newline) obj) +;;; +;;; Scheme music expression --> Lily-syntax-using string translator +;;; +(use-modules (srfi srfi-39) + (scm display-lily)) + +(define*-public (display-lily-music expr parser #: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)) + (newline))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (shift-one-duration-log music shift dot) - " add SHIFT to ly:duration-log and optionally +(define-public (shift-one-duration-log music shift dot) + " add SHIFT to duration-log of 'duration in music and optionally a dot to any note encountered. This scales the music up by a factor 2^shift * (2 - (1/2)^dot)" (let ((d (ly:music-property music 'duration))) @@ -193,12 +217,63 @@ Returns `obj'. (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)) +(define-public (make-repeat name times main alts) + "create a repeat music expression, with all properties initialized properly" + (define (first-note-duration music) + "Finds the duration of the first NoteEvent by searching depth-first +through MUSIC." + (if (memq 'note-event (ly:music-property music 'types)) + (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))) + (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 (equal? name "tremolo") + (let* ((dots (1- (logcount times))) + (mult (/ (* times (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 (integer? mult)) + (ly:warning (_ "invalid tremolo repeat count: ~a") times)) + (if (memq 'sequential-music (ly:music-property main 'types)) + ;; \repeat "tremolo" { c4 d4 } + (let ((children (length (ly:music-property main 'elements)))) + + ;; fixme: should be more generic. + (if (and (not (= children 2)) + (not (= children 1))) + (ly:warning (_ "expecting 2 elements for chord tremolo, found ~a") children)) + (ly:music-compress r (ly:make-moment 1 children)) + (shift-duration-log r + (if (= children 2) (1- shift) shift) + dots)) + ;; \repeat "tremolo" c4 + (shift-duration-log r shift dots))) + r))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. @@ -285,7 +360,18 @@ i.e. this is not an override" 'grob-property gprop)) (define direction-polyphonic-grobs - '(Stem Tie Rest Slur PhrasingSlur Script TextScript Dots DotColumn Fingering)) + '(DotColumn + Dots + Fingering + LaissezVibrerTie + PhrasingSlur + RepeatTie + Rest + Script + Slur + Stem + TextScript + Tie)) (define-safe-public (make-voice-props-set n) (make-sequential-music @@ -294,6 +380,17 @@ i.e. this is not an override" (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 NoteHead font-size -3) + (Voice Dots font-size -3) + (Voice Stem length-fraction 0.8) + (Voice Stem no-stem-extend #t) + (Voice Beam thickness 0.384) + (Voice Beam length-fraction 0.8) + (Voice Accidental font-size -4))) + (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) @@ -302,8 +399,9 @@ i.e. this is not an override" (append (map (lambda (x) (make-grob-property-revert x 'direction)) direction-polyphonic-grobs) - (list (make-grob-property-revert 'NoteColumn 'horizontal-shift)) - (list (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) + (list (make-property-unset 'graceSettings) + (make-grob-property-revert 'NoteColumn 'horizontal-shift) + (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) (define-safe-public (context-spec-music m context #:optional id) @@ -353,84 +451,39 @@ i.e. this is not an override" ;; mmrest (define-public (make-multi-measure-rest duration location) - (make-music 'MultiMeasureRestMusicGroup + (make-music 'MultiMeasureRestMusic 'origin location - 'elements (list (make-music 'BarCheck - 'origin location) - (make-event-chord (list (make-music 'MultiMeasureRestEvent - 'origin location - 'duration duration))) - (make-music 'BarCheck - 'origin location)))) - -(define-public (glue-mm-rest-texts music) - "Check if we have R1*4-\\markup { .. }, and if applicable convert to -a property set for MultiMeasureRestNumber." - (define (script-to-mmrest-text script-music) - "Extract 'direction and 'text from SCRIPT-MUSIC, and transform MultiMeasureTextEvent" - (let ((dir (ly:music-property script-music 'direction)) - (p (make-music 'MultiMeasureTextEvent - 'text (ly:music-property script-music 'text)))) - (if (ly:dir? dir) - (set! (ly:music-property p 'direction) dir)) - p)) - - (if (eq? (ly:music-property music 'name) 'MultiMeasureRestMusicGroup) - (let* ((text? (lambda (x) (memq 'script-event (ly:music-property x 'types)))) - (event? (lambda (x) (memq 'event (ly:music-property x 'types)))) - (group-elts (ly:music-property music 'elements)) - (texts '()) - (events '()) - (others '())) - - (set! texts - (map script-to-mmrest-text (filter text? group-elts))) - (set! group-elts - (remove text? group-elts)) - - (set! events (filter event? group-elts)) - (set! others (remove event? group-elts)) - - (if (or (pair? texts) (pair? events)) - (set! (ly:music-property music 'elements) - (cons (make-event-chord - (append texts events)) - others))) - - )) - - music) - + 'duration duration)) (define-public (make-property-set sym val) (make-music 'PropertySet 'symbol sym 'value val)) +(define-public (make-property-unset sym) + (make-music 'PropertyUnset + 'symbol sym)) + (define-public (make-ottava-set octavation) (let ((m (make-music 'ApplyContext))) (define (ottava-modify context) "Either reset middleCPosition to the stored original, or remember old middleCPosition, add OCTAVATION to middleCPosition, and set OTTAVATION to `8va', or whatever appropriate." - (if (number? (ly:context-property context 'middleCPosition)) - (if (= octavation 0) - (let ((where (ly:context-property-where-defined context 'middleCPosition)) - (oc0 (ly:context-property context 'originalCentralCPosition))) - (ly:context-set-property! context 'middleCPosition oc0) - (ly:context-unset-property where 'originalCentralCPosition) - (ly:context-unset-property where 'ottavation)) - (let* ((where (ly:context-property-where-defined context 'middleCPosition)) - (c0 (ly:context-property context 'middleCPosition)) - (new-c0 (+ c0 (* -7 octavation))) - (string (cdr (assoc octavation '((2 . "15ma") - (1 . "8va") - (0 . #f) - (-1 . "8va bassa") - (-2 . "15ma bassa")))))) - (ly:context-set-property! context 'middleCPosition new-c0) - (ly:context-set-property! context 'originalCentralCPosition c0) - (ly:context-set-property! context 'ottavation string))))) + (if (number? (ly:context-property context 'middleCOffset)) + (let ((where (ly:context-property-where-defined context 'middleCOffset))) + (ly:context-unset-property where 'middleCOffset) + (ly:context-unset-property where 'ottavation))) + + (let* ((offset (* -7 octavation)) + (string (cdr (assoc octavation '((2 . "15ma") + (1 . "8va") + (0 . #f) + (-1 . "8vb") + (-2 . "15mb")))))) + (ly:context-set-property! context 'middleCOffset offset) + (ly:context-set-property! context 'ottavation string) + (ly:set-middle-C! context))) (set! (ly:music-property m 'procedure) ottava-modify) (context-spec-music m 'Staff))) @@ -440,6 +493,23 @@ OTTAVATION to `8va', or whatever appropriate." (define-public (make-time-signature-set num den . rest) "Set properties for time signature NUM/DEN. Rest can contain a list of beat groupings " + + (define (standard-beat-grouping num den) + + "Some standard subdivisions for time signatures." + (let* + ((key (cons num den)) + (entry (assoc key '(((6 . 8) . (3 3)) + ((5 . 8) . (3 2)) + ((9 . 8) . (3 3 3)) + ((12 . 8) . (3 3 3 3)) + ((8 . 8) . (3 3 2)) + )))) + + (if entry + (cdr entry) + '()))) + (let* ((set1 (make-property-set 'timeSignatureFraction (cons num den))) (beat (ly:make-moment 1 den)) (len (ly:make-moment num den)) @@ -447,7 +517,7 @@ of beat groupings " (set3 (make-property-set 'measureLength len)) (set4 (make-property-set 'beatGrouping (if (pair? rest) (car rest) - '()))) + (standard-beat-grouping num den)))) (basic (list set1 set2 set3 set4))) (descend-to-context (context-spec-music (make-sequential-music basic) 'Timing) 'Score))) @@ -469,11 +539,6 @@ of beat groupings " (define-public (set-time-signature num den . rest) (ly:export (apply make-time-signature-set `(,num ,den . ,rest)))) -(define-safe-public (make-penalty-music pen page-pen) - (make-music 'BreakEvent - 'penalty pen - 'page-penalty page-pen)) - (define-safe-public (make-articulation name) (make-music 'ArticulationEvent 'articulation-type name)) @@ -483,9 +548,9 @@ of beat groupings " 'duration duration 'text string)) -(define-safe-public (make-span-event type spandir) +(define-safe-public (make-span-event type span-dir) (make-music type - 'span-direction spandir)) + 'span-direction span-dir)) (define-public (set-mus-properties! m alist) "Set all of ALIST as properties of M." @@ -521,7 +586,7 @@ of beat groupings " "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 es music-separator?) 0)) + (voicify-list (split-list-by-separator es music-separator?) 0)) ch)) (define-public (voicify-music m) @@ -542,9 +607,8 @@ of beat groupings " (define-public (empty-music) (ly:export (make-music 'Music))) -;;; - ; Make a function that checks score element for being of a specific type. +;; Make a function that checks score element for being of a specific type. (define-public (make-type-checker symbol) (lambda (elt) ;;(display symbol) @@ -589,19 +653,29 @@ of beat groupings " "Replace MUS by RestEvent of the same duration if it is a SkipEvent. Useful for extracting parts from crowded scores" - (if (equal? (ly:music-property mus 'name) 'SkipEvent) + (if (memq (ly:music-property mus 'name) '(SkipEvent SkipMusic)) (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) mus)) +(define-public (music-has-type music type) + (memq type (ly:music-property music 'types))) + +(define-public (music-clone music) + (define (alist->args alist acc) + (if (null? alist) + acc + (alist->args (cdr alist) + (cons (caar alist) (cons (cdar alist) acc))))) + + (apply + make-music + (ly:music-property music 'name) + (alist->args (ly:music-mutable-properties music) '()))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. -(define (has-request-chord elts) - (reduce (lambda (x y) (or x y)) #f - (map (lambda (x) - (equal? (ly:music-property x 'name) 'RequestChord)) - elts))) (define-public (ly:music-message music msg) (let ((ip (ly:music-property music 'origin))) @@ -609,25 +683,6 @@ SkipEvent. Useful for extracting parts from crowded scores" (ly:input-message ip msg) (ly:warning msg)))) -(define (check-start-chords music) - "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), -without context specification. Called from parser." - (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element)) - (name (ly:music-property music 'name))) - (cond ((equal? name "Context_specced_music") #t) - ((equal? name "Simultaneous_music") - (if (has-request-chord es) - (ly:music-message music "Starting score with a chord.\nInsert an explicit \\context before chord") - (map check-start-chords es))) - ((equal? name "SequentialMusic") - (if (pair? es) - (check-start-chords (car es)))) - (else (if (ly:music? e) (check-start-chords e))))) - music) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; setting stuff for grace context. @@ -654,7 +709,6 @@ without context specification. Called from parser." ((< i 0)) (f (vector-ref v i)))) -;; TODO: make a remove-grace-property too. (define-public (add-grace-property context-name grob sym val) "Set SYM=VAL for GROB in CONTEXT-NAME. " (define (set-prop context) @@ -665,10 +719,31 @@ without context specification. Called from parser." (ly:context-set-property! where 'graceSettings new-settings))) (ly:export (context-spec-music (make-apply-context set-prop) 'Voice))) +(define-public (remove-grace-property context-name grob sym) + "Remove all SYM for GROB in CONTEXT-NAME. " + (define (sym-grob-context? property sym grob context-name) + (and (eq? (car property) context-name) + (eq? (cadr property) grob) + (eq? (caddr property) sym))) + (define (delete-prop context) + (let* ((where (ly:context-property-where-defined context 'graceSettings)) + (current (ly:context-property where 'graceSettings)) + (prop-settings (filter + (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) + (ly:context-set-property! where 'graceSettings new-settings))) + (ly:export (context-spec-music (make-apply-context delete-prop) 'Voice))) + -(defmacro-public def-grace-function (start stop) - `(def-music-function (parser location music) (ly:music?) +(defmacro-public def-grace-function (start stop . docstring) + "Helper macro for defining grace music" + `(define-music-function (parser location music) (ly:music?) + ,@docstring (make-music 'GraceMusic 'origin location 'element (make-music 'SequentialMusic @@ -676,15 +751,24 @@ without context specification. Called from parser." music (ly:music-deep-copy ,stop)))))) -(defmacro-public def-music-function (args signature . body) +(defmacro-public define-music-function (args signature . body) "Helper macro for `ly:make-music-function'. Syntax: - (def-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) " - `(ly:make-music-function (list ,@signature) - (lambda (,@args) - ,@body))) +(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))) + `(ly:make-music-function (list ,@signature) + (lambda (,@args) + ,@body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -698,7 +782,7 @@ Syntax: (cue-voice (if (eq? 1 dir) 0 1)) (main-music (ly:music-property quote-music 'element)) (return-value quote-music)) - + (if (or (eq? 1 dir) (eq? -1 dir)) ;; if we have stem dirs, change both quoted and main music @@ -729,11 +813,15 @@ Syntax: (quoted-vector (if (string? quoted-name) (hash-ref quote-tab quoted-name #f) #f))) + (if (string? quoted-name) - (if (vector? quoted-vector) - (set! (ly:music-property music 'quoted-events) quoted-vector) - (ly:warning (_ "can't 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:warning (_ "cannot find quoted music: `~S'") quoted-name))) music)) @@ -766,43 +854,98 @@ Syntax: (ly:music-length music)) music) -(define (skip-to-last music parser) +(define-public (make-duration-of-length moment) + "Make duration of the given MOMENT length." + (ly:make-duration 0 0 + (ly:moment-main-numerator moment) + (ly:moment-main-denominator moment))) - "Replace MUSIC by +(define (skip-this moment) + "set skipTypesetting, make SkipMusic of the given MOMENT length, + and then unset skipTypesetting." + (make-sequential-music + (list + (context-spec-music (make-property-set 'skipTypesetting #t) + 'Score) + (make-music 'SkipMusic 'duration + (make-duration-of-length moment)) + (context-spec-music (make-property-set 'skipTypesetting #f) + 'Score)))) + +(define (unskip-this moment) + "unset skipTypesetting, make SkipMusic of the given MOMENT length, + and then set skipTypesetting." + (make-sequential-music + (list + (context-spec-music (make-property-set 'skipTypesetting #f) + 'Score) + (make-music 'SkipMusic 'duration + (make-duration-of-length moment)) + (context-spec-music (make-property-set 'skipTypesetting #t) + 'Score)))) + +(define (skip-as-needed music parser) + "Replace MUSIC by + << { \\set skipTypesetting = ##f + LENGTHOF(\\showFirstLength) + \\set skipTypesetting = ##t + LENGTHOF(\\showLastLength) } + MUSIC >> + if appropriate. + + When only showFirstLength is set, + the 'length property of the music is + overridden to speed up compiling." + (let* + ((show-last (ly:parser-lookup parser 'showLastLength)) + (show-first (ly:parser-lookup parser 'showFirstLength))) + (cond + + ;; both properties may be set. + ((and (ly:music? show-first) (ly:music? show-last)) + (let* + ((orig-length (ly:music-length music)) + (skip-length (ly:moment-sub orig-length (ly:music-length show-last))) + (begin-length (ly:music-length show-first))) + (make-simultaneous-music + (list + (make-sequential-music + (list + (skip-this skip-length) + ;; let's draw a separator between the beginning and the end + (context-spec-music (make-property-set 'whichBar "||") + 'Timing))) + (unskip-this begin-length) + music)))) + + ;; we may only want to print the last length + ((ly:music? show-last) + (let* + ((orig-length (ly:music-length music)) + (skip-length (ly:moment-sub orig-length (ly:music-length show-last)))) + (make-simultaneous-music + (list + (skip-this skip-length) + music)))) + + ;; we may only want to print the beginning; in this case + ;; only the first length will be processed (much faster). + ((ly:music? show-first) + (let* + ((orig-length (ly:music-length music)) + (begin-length (ly:music-length show-first))) + ;; the first length must not exceed the original length. + (if (ly:moment> - -if appropriate. - " - (let* - ((show-last (ly:parser-lookup parser 'showLastLength))) - - (if (ly:music? show-last) - (let* - ((orig-length (ly:music-length music)) - (skip-length (ly:moment-sub orig-length (ly:music-length show-last)))) - - (make-simultaneous-music - (list - (make-sequential-music - (list - (context-spec-music (make-property-set 'skipTypesetting #t) 'Score) - (make-music 'SkipMusic 'duration - (ly:make-duration 0 0 - (ly:moment-main-numerator skip-length) - (ly:moment-main-denominator skip-length))) - (context-spec-music (make-property-set 'skipTypesetting #f) 'Score))) - music))) - music))) - (define-public toplevel-music-functions (list (lambda (music parser) (voicify-music music)) - (lambda (x parser) (music-map glue-mm-rest-texts x)) (lambda (x parser) (music-map music-check-error x)) (lambda (x parser) (music-map precompute-music-length x)) (lambda (music parser) @@ -813,9 +956,20 @@ if appropriate. (lambda (x parser) (music-map cue-substitute x)) (lambda (x parser) - (skip-to-last 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))) + + ;;;;;;;;;;;;;;;;; ;; lyrics @@ -830,26 +984,203 @@ if appropriate. (music-map apply-duration lyric-music)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; - -(define-public ((add-balloon-text object-name text off) grob orig-context cur-context) - "Usage: see input/regression/balloon.ly " - (let* ((meta (ly:grob-property grob 'meta)) - (cb (ly:grob-property-data grob 'stencil)) - (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant"))) - (if (and (equal? nm object-name) - (procedure? cb)) - (begin - (ly:grob-set-property! grob 'stencil ly:balloon-interface::print) - (set! (ly:grob-property grob 'original-stencil) cb) - (set! (ly:grob-property grob 'balloon-text) text) - (set! (ly:grob-property grob 'balloon-text-offset) off) - (set! (ly:grob-property grob 'balloon-text-props) '((font-family . roman))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; accidentals +(define (recent-enough? bar-number alteration-def laziness) + (if (or (number? alteration-def) + (equal? laziness #t)) + #t + (<= bar-number (+ (cadr alteration-def) laziness)))) + +(define (is-tied? alteration-def) + (let* ((def (if (pair? alteration-def) + (car alteration-def) + alteration-def))) + + (if (equal? def 'tied) #t #f))) + +(define (extract-alteration alteration-def) + (cond ((number? alteration-def) + 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 +@code{localKeySignature}. The @var{laziness} is the number of measures +for which reminder accidentals are used (i.e., if @var{laziness} is zero, +only cancel accidentals in the same measure; if @var{laziness} is three, +we cancel accidentals up to three measures after they first appear. +@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 (ly:assoc-get pitch-handle local-key-sig)) + (from-key-sig (ly: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. + (if (equal? from-key-sig #f) + (set! from-key-sig (ly: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)))))) + + ;; find previous alteration-def for comparison with pitch + (cond + ;; from same octave? + ((and (eq? ignore-octave #f) + (not (equal? from-same-octave #f)) + (recent-enough? barnum from-same-octave laziness)) + (set! previous-alteration from-same-octave)) + + ;; from any octave? + ((and (eq? ignore-octave #t) + (not (equal? from-other-octaves #f)) + (recent-enough? barnum from-other-octaves laziness)) + (set! previous-alteration from-other-octaves)) + + ;; not recent enough, extract from key signature/local key signature + ((not (equal? from-key-sig #f)) + (set! previous-alteration from-key-sig))) + + (if (is-tied? previous-alteration) + (set! need-accidental #t) + + (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)) + (or (< (abs this-alt) (abs prev-alt)) + (< (* prev-alt this-alt) 0))) + (set! need-restore #t)))))) + + (cons need-restore need-accidental))) + +(define-public ((make-accidental-rule octaveness laziness) context pitch barnum measurepos) + "Creates an accidental rule that makes its decision based on the octave of the note + and a laziness value. + octaveness is either 'same-octave or 'any-octave and defines whether the rule should + respond to accidental changes in other octaves than the current. 'same-octave is the + normal way to typeset accidentals - an accidental is made if the alteration is different + from the last active pitch in the same octave. 'any-octave looks at the last active pitch + in any octave. + laziness states over how many bars an accidental should be remembered. + 0 is default - accidental lasts over 0 bar lines, that is, to the end of current measure. + A positive integer means that the accidental lasts over that many bar lines. + -1 is 'forget immediately', that is, only look at key signature. + #t is forever." + (check-pitch-against-signature context pitch barnum laziness octaveness)) + +(define (key-entry-notename entry) + "Return the pitch of an entry in localKeySignature. The entry is either of the form + '(notename . alter) or '((octave . notename) . (alter barnum . measurepos))." + (if (number? (car entry)) + (car entry) + (cdar entry))) + +(define (key-entry-octave entry) + "Return the octave of an entry in localKeySignature (or #f if the entry does not have + an octave)." + (and (pair? (car entry)) (caar entry))) + +(define (key-entry-bar-number entry) + "Return the bar number of an entry in localKeySignature (or #f if the entry does not + have a bar number)." + (and (pair? (car entry)) (caddr entry))) + +(define (key-entry-measure-position entry) + "Return the measure position of an entry in localKeySignature (or #f if the entry does + not have a measure position)." + (and (pair? (car entry)) (cdddr entry))) + +(define (key-entry-alteration entry) + "Return the alteration of an entry in localKeySignature." + (if (number? (car entry)) + (cdr entry) + (cadr entry))) + +(define-public (find-pitch-entry keysig pitch accept-global accept-local) + "Return the first entry in keysig that matches the pitch. + accept-global states whether key signature entries should be included. + accept-local states whether local accidentals should be included. + if no matching entry is found, #f is returned." + (if (pair? keysig) + (let* ((entry (car keysig)) + (entryoct (key-entry-octave entry)) + (entrynn (key-entry-notename entry)) + (oct (ly:pitch-octave pitch)) + (nn (ly:pitch-notename pitch))) + (if (and (equal? nn entrynn) + (or (and accept-global (equal? #f entryoct)) + (and accept-local (equal? oct entryoct)))) + entry + (find-pitch-entry (cdr keysig) pitch accept-global accept-local))) + #f)) + +(define-public (neo-modern-accidental-rule context pitch barnum measurepos) + "an accidental rule that typesets an accidental if it differs from the key signature + AND does not directly follow a note on the same staff-line. + This rule should not be used alone because it does neither look at bar lines + nor different accidentals at the same notename" + (let* ((keysig (ly:context-property context 'localKeySignature)) + (entry (find-pitch-entry keysig pitch #t #t))) + (if (equal? #f entry) + (cons #f #f) + (let* ((global-entry (find-pitch-entry keysig pitch #t #f)) + (key-acc (if (equal? global-entry #f) + 0 + (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 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))) + (if (equal? #f entry) + (cons #f #f) + (let* ((global-entry (find-pitch-entry keysig pitch #f #f)) + (key-acc (if (equal? global-entry #f) + 0 + (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 (set-accidentals-properties extra-natural auto-accs auto-cauts context) @@ -864,7 +1195,7 @@ if appropriate. (define-public (set-accidental-style style . rest) "Set accidental style to STYLE. Optionally takes a context argument, -e.g. 'Staff or 'Voice. The context defaults to Voice, except for piano styles, which +e.g. 'Staff or 'Voice. The context defaults to Staff, except for piano styles, which use GrandStaff as a context. " (let ((context (if (pair? rest) (car rest) 'Staff)) @@ -874,74 +1205,133 @@ use GrandStaff as a context. " (cond ;; accidentals as they were common in the 18th century. ((equal? style 'default) - (set-accidentals-properties #t '(Staff (same-octave . 0)) - '() context)) + (set-accidentals-properties #t + `(Staff ,(make-accidental-rule 'same-octave 0)) + '() + context)) ;; accidentals from one voice do NOT get cancelled in other voices ((equal? style 'voice) - (set-accidentals-properties #t '(Voice (same-octave . 0)) - '() context)) + (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 cancelling ;; in other octaves and in the next measure. ((equal? style 'modern) - (set-accidentals-properties #f '(Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) - '() context)) + (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 (same-octave . 0)) - '(Staff (any-octave . 0) (same-octave . 1)) + (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)) + ;; 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 cancelled across voices. ((equal? style 'modern-voice) (set-accidentals-properties #f - '(Voice (same-octave . 0) (any-octave . 0) (same-octave . 1) - Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) + `(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 (same-octave . 0)) - '(Voice (any-octave . 0) (same-octave . 1) - Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) + `(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 cancelled across the staves in the same grand staff as well ((equal? style 'piano) (set-accidentals-properties #f - '(Staff (same-octave . 0) - (any-octave . 0) (same-octave . 1) - GrandStaff (any-octave . 0) (same-octave . 1)) + `(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 (same-octave . 0)) - '(Staff (any-octave . 0) (same-octave . 1) - GrandStaff (any-octave . 0) (same-octave . 1)) + `(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 + ;; accidentals not being remembered, causing accidentals always to + ;; be typeset relative to the time signature ((equal? style 'forget) (set-accidentals-properties '() - '(Staff (same-octave . -1)) - '() context)) + `(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 (same-octave . #t)) + `(Staff ,(make-accidental-rule 'same-octave #t)) '() context)) (else - (ly:warning (_ "unknown accidental style: ~S" style)) + (ly:warning (_ "unknown accidental style: ~S") style) (make-sequential-music '())))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -974,3 +1364,34 @@ use GrandStaff as a context. " (ly:music-property (car evs) 'pitch) #f))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-public (extract-named-music music music-name) +"Return a flat list of all music named @code{music-name} +from @code{music}." + (let ((extracted-list + (if (ly:music? music) + (if (eq? (ly:music-property music 'name) music-name) + (list music) + (let ((elt (ly:music-property music 'element)) + (elts (ly:music-property music 'elements))) + (if (ly:music? elt) + (extract-named-music elt music-name) + (if (null? elts) + '() + (map (lambda(x) + (extract-named-music x music-name )) + elts))))) + '()))) + (flatten-list extracted-list))) + +(define-public (event-chord-notes event-chord) +"Return a list of all notes from @{event-chord}." + (filter + (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 @{event-chord}." + (map (lambda (x) (ly:music-property x 'pitch)) + (event-chord-notes event-chord)))