X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=383b7f3f6defb7e85373397b08b7b1000aaec08c;hb=1ca9814191d16fd3c571d93035247db039254fc1;hp=5e07229a3744663147f734bd0be659449b9eaaba;hpb=bd751630011a6fbfcf069ec1fc41a8eaed8a6b87;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 5e07229a37..383b7f3f6d 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -137,7 +137,7 @@ For instance, (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))) + (append-map inner-markup->make-markup arg)) ((and (not (string? arg)) (markup? arg)) ;; a markup (inner-markup->make-markup arg)) (else ;; scheme arg @@ -164,12 +164,12 @@ equivalent to @var{obj}, that is, for a music expression, a (ly:music? obj) `(make-music ',(ly:music-property obj 'name) - ,@(apply append (map (lambda (prop) - `(',(car prop) - ,(music->make-music (cdr prop)))) - (remove (lambda (prop) - (eqv? (car prop) 'origin)) - (ly:music-mutable-properties obj)))))) + ,@(append-map (lambda (prop) + `(',(car 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) @@ -503,6 +503,28 @@ in @var{grob}." TupletBracket TrillSpanner)) +(define general-grace-settings + `((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))) + +(define-public score-grace-settings + (append + `((Voice Stem direction ,UP) + (Voice Slur direction ,DOWN)) + general-grace-settings)) + (define-safe-public (make-voice-props-set n) (make-sequential-music (append @@ -510,26 +532,9 @@ in @var{grob}." (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))) - + (make-property-set 'graceSettings general-grace-settings) (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)))))) - (define-safe-public (make-voice-props-override n) (make-sequential-music (append @@ -537,25 +542,8 @@ in @var{grob}." (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))) - - (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) + (make-property-set 'graceSettings general-grace-settings) + (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)))))) (define-safe-public (make-voice-props-revert) (make-sequential-music @@ -563,8 +551,7 @@ in @var{grob}." (map (lambda (x) (make-grob-property-revert x 'direction)) 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))))) (define-safe-public (context-spec-music m context #:optional id) @@ -879,17 +866,23 @@ actually fully cloned." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. -(define-public (ly:music-message music msg) +(define-public (ly:music-message music msg . rest) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) - (ly:input-message ip msg) - (ly:message msg)))) + (apply ly:input-message ip msg rest) + (apply ly:message msg rest)))) -(define-public (ly:music-warning music msg) +(define-public (ly:music-warning music msg . rest) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) - (ly:input-warning ip msg) - (ly:warning msg)))) + (apply ly:input-warning ip msg rest) + (apply ly:warning msg rest)))) + +(define-public (ly:event-warning event msg . rest) + (let ((ip (ly:event-property event 'origin))) + (if (ly:input-location? ip) + (apply ly:input-warning ip msg rest) + (apply ly:warning msg rest)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -920,12 +913,12 @@ actually fully cloned." (define-public (add-grace-property context-name grob sym val) "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)) + (let* ((where (or (ly:context-find context context-name) context)) (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)) + (make-apply-context set-prop)) (define-public (remove-grace-property context-name grob sym) "Remove all @var{sym} for @var{grob} in @var{context-name}." @@ -934,7 +927,7 @@ actually fully cloned." (eq? (cadr property) grob) (eq? (caddr property) sym))) (define (delete-prop context) - (let* ((where (ly:context-property-where-defined context 'graceSettings)) + (let* ((where (or (ly:context-find context context-name) context)) (current (ly:context-property where 'graceSettings)) (prop-settings (filter (lambda(x) (sym-grob-context? x sym grob context-name)) @@ -944,8 +937,7 @@ actually fully cloned." (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)) - + (make-apply-context delete-prop)) (defmacro-public def-grace-function (start stop . docstring) @@ -981,24 +973,37 @@ predicates require the parameter to be entered as Scheme expression. predicates, to be used in case of a type error in arguments or result." + (define (currying-lambda args doc-string? body) + (if (and (pair? args) + (pair? (car args))) + (currying-lambda (car args) doc-string? + `((lambda ,(cdr args) ,@body))) + (if doc-string? + `(lambda ,args ,doc-string? ,@body) + `(lambda ,args ,@body)))) + (set! signature (map (lambda (pred) (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))) - `(ly:make-music-function (list ,@signature) - (lambda ,args - ,@body)))) + + (let ((docstring + (and (pair? body) (pair? (cdr body)) + (if (string? (car body)) + (car body) + (and (pair? (car body)) + (eq? '_i (caar body)) + (pair? (cdar body)) + (string? (cadar body)) + (null? (cddar body)) + (cadar body)))))) + ;; When the music function definition contains an i10n doc string, + ;; (_i "doc string"), keep the literal string only + `(ly:make-music-function + (list ,@signature) + ,(currying-lambda args docstring (if docstring (cdr body) body))))) (defmacro-public define-music-function rest "Defining macro returning music functions. @@ -1089,6 +1094,8 @@ set to the @code{location} parameter." (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))) + (cue-type (ly:music-property quote-music 'quoted-context-type #f)) + (cue-id (ly:music-property quote-music 'quoted-context-id)) (main-music (ly:music-property quote-music 'element)) (return-value quote-music)) @@ -1110,17 +1117,15 @@ set to the @code{location} parameter." (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") + (and cue-type cue-voice + (context-spec-music + (make-voice-props-override cue-voice) + cue-type cue-id)) quote-music - (and cue-voice + (and cue-type cue-voice (context-spec-music - (make-voice-props-revert) 'CueVoice "cue")) + (make-voice-props-revert) + cue-type cue-id)) (and clef (make-cue-clef-unset)))))) quote-music)) @@ -1756,7 +1761,11 @@ Entries that conform with the current key signature are not invalidated." (define-public (map-some-music map? music) "Walk through @var{music}, transform all elements calling @var{map?} -and only recurse if this returns @code{#f}." +and only recurse if this returns @code{#f}. @code{elements} or +@code{articulations} that are not music expressions are discarded: +this allows some amount of filtering. + +@code{map-some-music} may overwrite the original @var{music}." (let loop ((music music)) (or (map? music) (let ((elt (ly:music-property music 'element)) @@ -1767,10 +1776,10 @@ and only recurse if this returns @code{#f}." (loop elt))) (if (pair? elts) (set! (ly:music-property music 'elements) - (map loop elts))) + (filter! ly:music? (map! loop elts)))) (if (pair? arts) (set! (ly:music-property music 'articulations) - (map loop arts))) + (filter! ly:music? (map! loop arts)))) music)))) (define-public (for-some-music stop? music) @@ -1944,9 +1953,9 @@ base onto the following musical context." (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) + (for-each (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 @@ -1978,7 +1987,7 @@ other stems just because of that." ;; two stems at this musical moment (if (<= 2 (length stems)) (let ((roots (filter stem-is-root? stems))) - (map (make-stem-span! stems trans) roots)))) + (for-each (make-stem-span! stems trans) roots)))) (define-public (Span_stem_engraver ctx) "Connect cross-staff stems to the stems above in the system" @@ -2072,3 +2081,96 @@ Broken measures are numbered in parentheses." (cdr break-alignment-L-ext)))) X))) num)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The following are used by the \offset function + +(define (find-value-to-offset prop self alist) + "Return the first value of the property @var{prop} in the property +alist @var{alist} -- after having found @var{self}. If @var{self} is +not found, return the first value of @var{prop}." + (let ((segment (member (cons prop self) alist))) + (if (not segment) + (assoc-get prop alist) + (assoc-get prop (cdr segment))))) + +(define (offset-multiple-types arg offsets) + "Displace @var{arg} by @var{offsets} if @var{arg} is a number, a +number pair, or a list of number pairs. If @var{offsets} is an empty +list or if there is a type-mismatch, @var{arg} will be returned." + (cond + ((and (number? arg) (number? offsets)) + (+ arg offsets)) + ((and (number-pair? arg) + (or (number? offsets) + (number-pair? offsets))) + (coord-translate arg offsets)) + ((and (number-pair-list? arg) (number-pair-list? offsets)) + (map + (lambda (x y) (coord-translate x y)) + arg offsets)) + (else arg))) + +(define-public (offsetter property offsets) + "Apply @var{offsets} to the default values of @var{property} of @var{grob}. +Offsets are restricted to immutable properties and values of type @code{number}, +@code{number-pair}, or @code{number-pair-list}." + (define (self grob) + (let* ((immutable (ly:grob-basic-properties grob)) + ; We need to search the basic-properties alist for our property to + ; obtain values to offset. Our search is complicated by the fact that + ; calling the music function `offset' as an override conses a pair to + ; the head of the alist. This pair must be discounted. The closure it + ; contains is named `self' so it can be easily recognized. If `offset' + ; is called as a tweak, the basic-property alist is unaffected. + (target (find-value-to-offset property self immutable)) + ; if target is a procedure, we need to apply it to our grob to calculate + ; values to offset. + (vals + (if (procedure? target) + (target grob) + target)) + (can-type-be-offset? + (or (number? vals) + (number-pair? vals) + (number-pair-list? vals)))) + + (if can-type-be-offset? + ; '(+inf.0 . -inf.0) would offset to itself. This will be confusing to a + ; user unaware of the default value of the property, so issue a warning. + (if (equal? empty-interval vals) + (ly:warning "default '~a of ~a is ~a and can't be offset" + property grob vals) + (let* ((orig (ly:grob-original grob)) + (siblings + (if (ly:spanner? grob) + (ly:spanner-broken-into orig) + '())) + (total-found (length siblings)) + ; Since there is some flexibility in input syntax, + ; structure of `offsets' is normalized. + (offsets + (if (or (not (pair? offsets)) + (number-pair? offsets) + (and (number-pair-list? offsets) + (number-pair-list? vals))) + (list offsets) + offsets))) + + (define (helper sibs offs) + ; apply offsets to the siblings of broken spanners + (if (pair? offs) + (if (eq? (car sibs) grob) + (offset-multiple-types vals (car offs)) + (helper (cdr sibs) (cdr offs))) + vals)) + + (if (>= total-found 2) + (helper siblings offsets) + (offset-multiple-types vals (car offsets))))) + + (begin + (ly:warning "the property '~a of ~a cannot be offset" property grob) + vals)))) + ; return the closure named `self' + self)