X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=8c2dc27f9c2b29ad9fcbbd4ff543cdce3fed4195;hb=07cba348de41ccb71a4707726b2f6c5510f33d49;hp=5011a0a0ee90a16188dd5ed0ebef052e81a8ab54;hpb=25073ea9fc0772d7282aa311dd57dceb9d921046;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 5011a0a0ee..8c2dc27f9c 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -1,11 +1,11 @@ -;;;; music-functions.scm -- implement Scheme output routines for PostScript +;;;; music-functions.scm -- ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2004 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; (c) 1998--2005 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys -(use-modules (ice-9 optargs)) +;; (use-modules (ice-9 optargs)) ;;; ly:music-property with setter ;;; (ly:music-property my-music 'elements) @@ -21,7 +21,10 @@ ly:grob-set-property!)) (define-public (music-map function music) - "Apply @var{function} to @var{music} and all of the music it contains. " + "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 MUSIC. +" (let ((es (ly:music-property music 'elements)) (e (ly:music-property music 'element))) (set! (ly:music-property music 'elements) @@ -48,7 +51,7 @@ (set! (ly:music-property music 'elements) filtered-es) (set! (ly:music-property music 'articulations) filtered-as) ;; if filtering emptied the expression, we remove it completely. - (if (or (pred? music) + (if (or (not (pred? music)) (and (eq? filtered-es '()) (not (ly:music? e)) (or (not (eq? es '())) (ly:music? e)))) @@ -60,22 +63,13 @@ music (make-music 'Music))) ;must return music. -(define-public (remove-tag tag) - (lambda (mus) - (music-filter - (lambda (m) - (let* ((tags (ly:music-property m 'tags)) - (res (memq tag tags))) - res)) - mus))) - (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)) (e (ly:music-property music 'element))) - (display (ly:get-mutable-properties music)) + (display (ly:music-mutable-properties music)) (if (pair? es) (begin (display "\nElements: {\n") (map display-music es) @@ -87,7 +81,6 @@ (display " }\n") music) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (shift-one-duration-log music shift dot) @@ -109,7 +102,6 @@ (define-public (shift-duration-log music shift dot) (music-map (lambda (x) (shift-one-duration-log x shift dot)) music)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. @@ -130,22 +122,37 @@ (define-public (unfold-repeats music) " -This function replaces all repeats with unfold repeats. It was -written by Rune Zedeler. " +This function replaces all repeats with unfold repeats. " + (let ((es (ly:music-property music 'elements)) (e (ly:music-property music 'element)) - (n (ly:music-name music))) - (if (equal? n "Repeated_music") + ) + (if (memq 'repeated-music (ly:music-property music 'types)) (begin (if (equal? (ly:music-property music 'iterator-ctor) Chord_tremolo_iterator::constructor) - (shift-duration-log music (ly:intlog2 (ly:music-property music 'repeat-count)) 0)) - (set! (ly:music-property music 'length) + (let* ((seq-arg? (memq 'sequential-music + (ly:music-property e 'types))) + (count (ly:music-property music 'repeat-count)) + (dot-shift (if (= 0 (remainder count 3)) + -1 0))) + + (if (= 0 -1) + (set! count (* 2 (quotient count 3)))) + + (shift-duration-log music (+ (if seq-arg? 1 0) + (ly:intlog2 count)) dot-shift) + + (if seq-arg? + (ly:music-compress e (ly:make-moment (length (ly:music-property e 'elements)) 1))))) + + (set! (ly:music-property music 'length-callback) Repeated_music::unfolded_music_length) - (set! (ly:music-property music 'start-moment-function) + (set! (ly:music-property music 'start-callback) Repeated_music::first_start) (set! (ly:music-property music 'iterator-ctor) Unfolded_repeat_iterator::constructor))) + (if (pair? es) (set! (ly:music-property music 'elements) (map unfold-repeats es))) @@ -154,7 +161,6 @@ written by Rune Zedeler. " (unfold-repeats e))) music)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property setting music objs. @@ -182,27 +188,28 @@ i.e. this is not an override" 'grob-property gprop)) (define direction-polyphonic-grobs - '(Tie Rest Slur Script TextScript Stem Dots DotColumn)) + '(Stem Tie Rest Slur Script TextScript Dots DotColumn Fingering)) -(define-public (make-voice-props-set n) +(define-safe-public (make-voice-props-set n) (make-sequential-music (append (map (lambda (x) (make-grob-property-set x 'direction (if (odd? n) -1 1))) direction-polyphonic-grobs) - (list (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-set 'MultiMeasureRest 'staff-position - (if (odd? n) -4 4)))))) + (list + (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) + (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) -(define-public (make-voice-props-revert) +(define-safe-public (make-voice-props-revert) (make-sequential-music (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 'NoteColumn 'horizontal-shift)) + (list (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) -(define*-public (context-spec-music m context #:optional id) +(define-safe-public (context-spec-music m context #:optional id) "Add \\context CONTEXT = ID to M. " (let ((cm (make-music 'ContextSpeccedMusic 'element m @@ -211,6 +218,16 @@ i.e. this is not an override" (set! (ly:music-property cm 'context-id) id)) cm)) +(define-public (descend-to-context m context) + "Like context-spec-music, but only descending. " + (let ((cm (context-spec-music m context))) + (ly:music-set-property! cm 'descend-only #t) + cm)) + +(define-public (make-non-relative-music mus) + (make-music 'UnrelativableMusic + 'element mus)) + (define-public (make-apply-context func) (make-music 'ApplyContext 'procedure func)) @@ -223,7 +240,7 @@ i.e. this is not an override" (make-music 'SimultaneousMusic 'elements elts)) -(define-public (make-event-chord elts) +(define-safe-public (make-event-chord elts) (make-music 'EventChord 'elements elts)) @@ -231,6 +248,10 @@ i.e. this is not an override" (make-music 'SkipMusic 'duration dur)) +(define-public (make-grace-music music) + (make-music 'GraceMusic + 'element music)) + ;;;;;;;;;;;;;;;; ;; mmrest @@ -249,7 +270,7 @@ i.e. this is not an override" "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 into property sets." + "Extract 'direction and 'text from SCRIPT-MUSIC, and transform into property sets." (let ((dir (ly:music-property script-music 'direction)) (p (make-music 'MultiMeasureTextEvent 'text (ly:music-property script-music 'text)))) @@ -275,25 +296,25 @@ a property set for MultiMeasureRestNumber." (define-public (make-ottava-set octavation) (let ((m (make-music 'ApplyContext))) (define (ottava-modify context) - "Either reset centralCPosition to the stored original, or remember -old centralCPosition, add OCTAVATION to centralCPosition, and set + "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 'centralCPosition)) + (if (number? (ly:context-property context 'middleCPosition)) (if (= octavation 0) - (let ((where (ly:context-property-where-defined context 'centralCPosition)) + (let ((where (ly:context-property-where-defined context 'middleCPosition)) (oc0 (ly:context-property context 'originalCentralCPosition))) - (ly:context-set-property! context 'centralCPosition oc0) - (ly:unset-context-property where 'originalCentralCPosition) - (ly:unset-context-property where 'ottavation)) - (let* ((where (ly:context-property-where-defined context 'centralCPosition)) - (c0 (ly:context-property context 'centralCPosition)) + (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 'centralCPosition new-c0) + (ly:context-set-property! context 'middleCPosition new-c0) (ly:context-set-property! context 'originalCentralCPosition c0) (ly:context-set-property! context 'ottavation string))))) (set! (ly:music-property m 'procedure) ottava-modify) @@ -303,10 +324,8 @@ OTTAVATION to `8va', or whatever appropriate." (ly:export (make-ottava-set ottavation))) (define-public (make-time-signature-set num den . rest) - " Set properties for time signature NUM/DEN. -Rest can contain a list of beat groupings - -" + "Set properties for time signature NUM/DEN. Rest can contain a list +of beat groupings " (let* ((set1 (make-property-set 'timeSignatureFraction (cons num den))) (beat (ly:make-moment 1 den)) (len (ly:make-moment num den)) @@ -316,11 +335,11 @@ Rest can contain a list of beat groupings (car rest) '()))) (basic (list set1 set2 set3 set4))) - (context-spec-music + (descend-to-context (context-spec-music (make-sequential-music basic) 'Timing) 'Score))) (define-public (make-mark-set label) - "make the music for the \\mark command." + "Make the music for the \\mark command." (let* ((set (if (integer? label) (context-spec-music (make-property-set 'rehearsalMark label) 'Score) @@ -336,11 +355,12 @@ Rest can contain a list of beat groupings (define-public (set-time-signature num den . rest) (ly:export (apply make-time-signature-set `(,num ,den . ,rest)))) -(define-public (make-penalty-music pen) +(define-safe-public (make-penalty-music pen page-pen) (make-music 'BreakEvent - 'penalty pen)) + 'penalty pen + 'page-penalty page-pen)) -(define-public (make-articulation name) +(define-safe-public (make-articulation name) (make-music 'ArticulationEvent 'articulation-type name)) @@ -349,7 +369,7 @@ Rest can contain a list of beat groupings 'duration duration 'text string)) -(define-public (make-span-event type spandir) +(define-safe-public (make-span-event type spandir) (make-music type 'span-direction spandir)) @@ -365,24 +385,23 @@ Rest can contain a list of beat groupings (let ((ts (ly:music-property m 'types))) (memq 'separator ts))) - ;;; splitting chords into voices. (define (voicify-list lst number) - "Make a list of Musics. + "Make a list of Musics. voicify-list :: [ [Music ] ] -> number -> [Music] LST is a list music-lists. NUMBER is 0-base, i.e. Voice=1 (upstems) has number 0. " - (if (null? lst) - '() - (cons (context-spec-music - (make-sequential-music - (list (make-voice-props-set number) - (make-simultaneous-music (car lst)))) - 'Voice (number->string (1+ number))) - (voicify-list (cdr lst) (1+ number))))) + (if (null? lst) + '() + (cons (context-spec-music + (make-sequential-music + (list (make-voice-props-set number) + (make-simultaneous-music (car lst)))) + 'Voice (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" @@ -398,11 +417,12 @@ Rest can contain a list of beat groupings (error "not music!"))) (let ((es (ly:music-property m 'elements)) (e (ly:music-property m 'element))) + (if (pair? es) (set! (ly:music-property m 'elements) (map voicify-music es))) (if (ly:music? e) (set! (ly:music-property m 'element) (voicify-music e))) - (if (and (equal? (ly:music-name m) "Simultaneous_music") + (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) (reduce (lambda (x y ) (or x y)) #f (map music-separator? es))) (set! m (context-spec-music (voicify-chord m) 'Staff))) m)) @@ -411,7 +431,7 @@ Rest can contain a list of beat groupings (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) @@ -424,14 +444,14 @@ Rest can contain a list of beat groupings (define-public ((set-output-property grob-name symbol val) grob grob-c context) - "Usage: + "Usage: \\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1)) " - (let ((meta (ly:grob-property grob 'meta))) - (if (equal? (cdr (assoc 'name meta)) grob-name) - (set! (ly:grob-property grob symbol) val)))) + (let ((meta (ly:grob-property grob 'meta))) + (if (equal? (cdr (assoc 'name meta)) grob-name) + (set! (ly:grob-property grob symbol) val)))) ;; @@ -455,7 +475,7 @@ Rest can contain a list of beat groupings (define (has-request-chord elts) (reduce (lambda (x y) (or x y)) #f (map (lambda (x) - (equal? (ly:music-name x) "Request_chord")) + (equal? (ly:music-property x 'name) 'RequestChord)) elts))) (define (ly:music-message music msg) @@ -463,19 +483,19 @@ Rest can contain a list of beat groupings (if (ly:input-location? ip) (ly:input-message ip msg) (ly:warn 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-name music))) + (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.\nPlease insert an explicit \\context before chord") + (ly:music-message music "Starting score with a chord.\nInsert an explicit \\context before chord") (map check-start-chords es))) - ((equal? name "Sequential_music") + ((equal? name "SequentialMusic") (if (pair? es) (check-start-chords (car es)))) (else (if (ly:music? e) (check-start-chords e))))) @@ -490,9 +510,8 @@ without context specification. Called from parser." (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) '()))) + (let* ((n (vector-length v)) + (nv (make-vector (+ n 1) '()))) (vector-move-left! v 0 n nv 0) (vector-set! nv n x) nv)) @@ -516,30 +535,83 @@ without context specification. Called from parser." (define (set-prop context) (let* ((where (ly:context-property-where-defined context 'graceSettings)) (current (ly:context-property where 'graceSettings)) - (new-settings (vector-extend current (list context-name grob sym val)))) + (new-settings (append current + (list (list context-name grob sym val))))) (ly:context-set-property! where 'graceSettings new-settings))) (ly:export (context-spec-music (make-apply-context set-prop) 'Voice))) -(define-public (set-start-grace-properties context) - (define (execute-1 x) - (let ((tr (ly:translator-find context (car x)))) - (if (ly:context? tr) - (ly:context-pushpop-property tr (cadr x) (caddr x) (cadddr x))))) - - (let ((props (ly:context-property context 'graceSettings))) - (if (vector? props) - (vector-map execute-1 props)))) - -(define-public (set-stop-grace-properties context) - (define (execute-1 x) - (let ((tr (ly:translator-find context (car x)))) - (if (ly:context? tr) - (ly:context-pushpop-property tr (cadr x) (caddr x))))) + +(defmacro-public def-grace-function (start stop) + `(def-music-function (parser location music) (ly:music?) + (make-music 'GraceMusic + 'origin location + 'element (make-music 'SequentialMusic + 'elements (list (ly:music-deep-copy ,start) + music + (ly:music-deep-copy ,stop)))))) + +(defmacro-public def-music-function (args signature . body) + "Helper macro for `ly:make-music-function'. +Syntax: + (def-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + ...function body...) +" + `(ly:make-music-function (list ,@signature) + (lambda (,@args) + ,@body))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-public (cue-substitute quote-music) + "Must happen after quote-substitute." - (let ((props (ly:context-property context 'graceSettings))) - (if (vector? props) - (vector-reverse-map execute-1 props)))) + (if (vector? (ly:music-property quote-music 'quoted-events)) + (let* ((dir (ly:music-property quote-music 'quoted-voice-direction)) + (main-voice (if (eq? 1 dir) 1 0)) + (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 + ;; to have opposite stems. + (begin + (set! return-value + + ;; cannot context-spec Quote-music, since context + ;; for the quotes is determined in the iterator. + (make-sequential-music + (list + (context-spec-music (make-voice-props-set cue-voice) 'Voice "cue") + quote-music + (context-spec-music (make-voice-props-revert) 'Voice "cue")))) + (set! main-music + (make-sequential-music + (list + (make-voice-props-set main-voice) + main-music + (make-voice-props-revert)))) + (set! (ly:music-property quote-music 'element) main-music))) + + return-value) + quote-music)) + +(define-public ((quote-substitute quote-tab) music) + (let* ((quoted-name (ly:music-property music 'quoted-music-name)) + (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:warn "Cannot find quoted music `~S'" quoted-name))) + + music)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; switch it on here, so parsing and init isn't checked (too slow!) @@ -547,16 +619,41 @@ without context specification. Called from parser." ;; automatic music transformations. (define (switch-on-debugging m) - (set-debug-cell-accesses! 15000) + (if (defined? 'set-debug-cell-accesses!) + (set-debug-cell-accesses! 15000)) m) +(define (music-check-error music) + (define found #f) + (define (signal m) + (if (and (ly:music? m) + (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)) + + (if found + (set! (ly:music-property music 'error-found) #t)) + music) + +(define (precompute-music-length music) + (set! (ly:music-property music 'length) + (ly:music-length music)) + music) + (define-public toplevel-music-functions (list ;; check-start-chords ; ; no longer needed with chord syntax. - voicify-music - (lambda (x) (music-map glue-mm-rest-texts x)) + (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) + + (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes)) music)) ;; switch-on-debugging - )) + (lambda (x parser) (music-map cue-substitute x)))) ;;;;;;;;;;;;;;;;; ;; lyrics @@ -576,7 +673,7 @@ without context specification. Called from parser." ;; (define-public ((add-balloon-text object-name text off) grob orig-context cur-context) - "Usage: see input/regression/balloon.ly " + "Usage: see input/regression/balloon.ly " (let* ((meta (ly:grob-property grob 'meta)) (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant")) (cb (ly:grob-property grob 'print-function))) @@ -605,12 +702,12 @@ without context specification. Called from parser." (define-public (set-accidental-style style . rest) "Set accidental style to STYLE. Optionally takes a context argument, -eg. 'Staff or 'Voice. The context defaults to Voice, except for piano styles, which -use PianoStaff as a context. " +e.g. 'Staff or 'Voice. The context defaults to Voice, except for piano styles, which +use GrandStaff as a context. " (let ((context (if (pair? rest) (car rest) 'Staff)) (pcontext (if (pair? rest) - (car rest) 'PianoStaff))) + (car rest) 'GrandStaff))) (ly:export (cond ;; accidentals as they were common in the 18th century. @@ -645,7 +742,7 @@ use PianoStaff as a context. " ;; as cautionaries ((equal? style 'modern-voice-cautionary) (set-accidentals-properties #f - '(Voice (same-octave . 0) ) + '(Voice (same-octave . 0)) '(Voice (any-octave . 0) (same-octave . 1) Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) context)) @@ -653,15 +750,16 @@ use PianoStaff as a context. " ;; 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) - PianoStaff (any-octave . 0) (same-octave . 1)) + '(Staff (same-octave . 0) + (any-octave . 0) (same-octave . 1) + GrandStaff (any-octave . 0) (same-octave . 1)) '() pcontext)) ((equal? style 'piano-cautionary) (set-accidentals-properties #f '(Staff (same-octave . 0)) '(Staff (any-octave . 0) (same-octave . 1) - PianoStaff (any-octave . 0) (same-octave . 1)) + GrandStaff (any-octave . 0) (same-octave . 1)) pcontext)) ;; do not set localKeySignature when a note alterated differently from ;; localKeySignature is found. @@ -681,7 +779,25 @@ use PianoStaff as a context. " '() context)) (else - (ly:warn (string-append "Unknown accidental style: " (symbol->string style))) + (ly:warn "Unknown accidental style: ~S" (symbol->string style)) (make-sequential-music '())))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-public (skip-of-length mus) + "Create a skip of exactly the same length as MUS." + (let* ((skip + (make-music + 'SkipEvent + 'duration (ly:make-duration 0 0)))) + (make-event-chord (list (ly:music-compress skip (ly:music-length mus)))))) + +(define-public (mmrest-of-length mus) + "Create a mmrest of exactly the same length as MUS." + + (let* ((skip + (make-multi-measure-rest + (ly:make-duration 0 0) '()))) + (ly:music-compress skip (ly:music-length mus)) + skip))