X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=724165a88f399d9e02d4877f256990bd1763860b;hb=6ec65b15b95eb3bd700579a9f85ce209ecd0812d;hp=a71e8705695a1a21fd5644e3e880a9bf8a4a28b8;hpb=0bf2e8b7a385573b3796f80b08d3f2d87d9e1e16;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index a71e870569..724165a88f 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2005 Jan Nieuwenhuizen +;;;; (c) 1998--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;; (use-modules (ice-9 optargs)) @@ -16,10 +16,16 @@ (make-procedure-with-setter ly:music-property ly:music-set-property!)) + +;; TODO move this (define-public ly:grob-property (make-procedure-with-setter ly:grob-property ly:grob-set-property!)) +(define-public ly:prob-property + (make-procedure-with-setter ly:prob-property + ly:prob-set-property!)) + (define-public (music-map function music) "Apply @var{function} to @var{music} and all of the music it contains. @@ -96,81 +102,80 @@ For instance, (symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-markup) (string-length "-markup"))))))) (define (transform-arg arg) - (cond ((and (pair? arg) (pair? (car arg))) ;; a markup list + (cond ((and (pair? arg) (markup? (car arg))) ;; a markup list (apply append (map inner-markup->make-markup arg))) - ((pair? arg) ;; a markup + ((and (not (string? arg)) (markup? arg)) ;; a markup (inner-markup->make-markup arg)) - (else ;; scheme arg + (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))) ;; body: - `(markup ,@(inner-markup->make-markup markup-expression))) + (if (string? markup-expression) + markup-expression + `(markup ,@(inner-markup->make-markup markup-expression)))) -(define (music-expression? obj) - (ly:music? obj)) - -(define*-public (music-pretty-string obj #:optional (depth 0)) - "Return a string describing `obj', in particular music expression -will be printed as: (make-music 'MusicType 'property ...)" - +(define-public (music->make-music obj) + "Generate a expression that, once evaluated, may return an object equivalent to `obj', +that is, for a music expression, a (make-music ...) form." (cond (;; markup expression (markup? obj) - (format #f "~a" (markup-expression->make-markup obj))) + (markup-expression->make-markup obj)) (;; music expression - (music-expression? obj) - (format #f "(make-music '~a~{~a~})" - (ly:music-property obj 'name) - (map (lambda (prop) - (format #f "~%~v_'~a ~a" - (+ 2 (* 13 depth)) - (car prop) - (cond (;; property is a markup expression - (markup? (cdr prop)) - (music-pretty-string (cdr prop) (1+ depth))) - (;; property is a list - (list? (cdr prop)) - (format #f "(list ~{~a~})" - (map (lambda (mus) - (format #f "~%~v_~a" - (* 13 (1+ depth)) - (music-pretty-string mus (1+ depth)))) - (cdr prop)))) - (;; property is a string - (string? (cdr prop)) - (string-append "\"" (cdr prop) "\"")) - (else ;; property is something else - (music-pretty-string (cdr prop) (1+ depth)))))) - (remove (lambda (prop) - (eqv? (car prop) 'origin)) - (ly:music-mutable-properties obj))))) - (;; string - (string? obj) (format #f "~s" obj)) - (;; symbol - (symbol? obj) (format #f "'~a" obj)) + (ly:music? obj) + `(make-music + ',(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))))) + (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) (format #f "(ly:make-duration ~a ~a ~a ~a)" - (ly:duration-log obj) - (ly:duration-dot-count obj) - (car (ly:duration-factor obj)) - (cdr (ly:duration-factor obj)))) + (ly:duration? obj) + `(ly:make-duration ,(ly:duration-log obj) + ,(ly:duration-dot-count obj) + ,(car (ly:duration-factor obj)) + ,(cdr (ly:duration-factor obj)))) (;; note pitch - (ly:pitch? obj) (format #f "(ly:make-pitch ~a ~a ~a)" - (ly:pitch-octave obj) - (ly:pitch-notename obj) - (ly:pitch-alteration obj))) + (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) (format #f "(lambda ...)"))) + (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) + `'()) (else - (format #f "~a" obj)))) + obj))) -(define-public (display-scheme-music obj) +(use-modules (ice-9 pretty-print)) +(define*-public (display-scheme-music obj #:optional (port (current-output-port))) "Displays `obj', typically a music expression, in a friendly fashion, -which often can be read back in order to generate an equivalent expression." - (display (music-pretty-string obj)) - (newline)) +which often can be read back in order to generate an equivalent expression. + +Returns `obj'. +" + (pretty-print (music->make-music obj) port) + (newline) + obj) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -214,14 +219,20 @@ which often can be read back in order to generate an equivalent expression." (define-public (unfold-repeats music) " This function replaces all repeats with unfold repeats. " - + (let ((es (ly:music-property music 'elements)) (e (ly:music-property music 'element)) ) (if (memq 'repeated-music (ly:music-property music 'types)) - (begin - (if (equal? (ly:music-property music 'iterator-ctor) - Chord_tremolo_iterator::constructor) + (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 (equal? old-name 'TremoloRepeatedMusic) (let* ((seq-arg? (memq 'sequential-music (ly:music-property e 'types))) (count (ly:music-property music 'repeat-count)) @@ -235,14 +246,9 @@ This function replaces all repeats with unfold repeats. " (ly:intlog2 count)) dot-shift) (if seq-arg? - (ly:music-compress e (ly:make-moment (length (ly:music-property e 'elements)) 1))))) + (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-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) @@ -274,12 +280,12 @@ i.e. this is not an override" (define-public (make-grob-property-revert grob gprop) "Revert the grob property GPROP for GROB." - (make-music 'OverrideProperty + (make-music 'RevertProperty 'symbol grob 'grob-property gprop)) (define direction-polyphonic-grobs - '(Stem Tie Rest Slur Script TextScript Dots DotColumn Fingering)) + '(Stem Tie Rest Slur PhrasingSlur Script TextScript Dots DotColumn Fingering)) (define-safe-public (make-voice-props-set n) (make-sequential-music @@ -361,21 +367,38 @@ 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 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)))) - (es (ly:music-property music 'elements)) - (texts (map script-to-mmrest-text (filter text? es))) - (others (remove text? es))) - (if (pair? texts) + (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 texts) others))))) + (cons (make-event-chord + (append texts events)) + others))) + + )) + music) @@ -504,8 +527,7 @@ of beat groupings " (define-public (voicify-music m) "Recursively split chords that are separated with \\ " (if (not (ly:music? m)) - (begin (display m) - (error "not music!"))) + (ly:error (_ "music expected: ~S") m)) (let ((es (ly:music-property m 'elements)) (e (ly:music-property m 'element))) @@ -554,12 +576,24 @@ of beat groupings " (let* ((bn (ly:context-property tr 'currentBarNumber))) (if (= bn n) #t - (error - (format "Bar check failed, we should have reached ~a, instead at ~a\n" - n bn))))) + (ly:error + ;; FIXME: uncomprehensable message + (_ "Bar check failed. Expect to be at ~a, instead at ~a") + n bn)))) (set! (ly:music-property m 'procedure) checker) m)) + +(define-public (skip->rest mus) + + "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) + (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) + mus)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. @@ -569,11 +603,11 @@ of beat groupings " (equal? (ly:music-property x 'name) 'RequestChord)) elts))) -(define (ly:music-message music msg) +(define-public (ly:music-message music msg) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) (ly:input-message ip msg) - (ly:warn msg)))) + (ly:warning msg)))) (define (check-start-chords music) "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), @@ -676,9 +710,9 @@ Syntax: ;; for the quotes is determined in the iterator. (make-sequential-music (list - (context-spec-music (make-voice-props-set cue-voice) 'Voice "cue") + (context-spec-music (make-voice-props-set cue-voice) 'CueVoice "cue") quote-music - (context-spec-music (make-voice-props-revert) 'Voice "cue")))) + (context-spec-music (make-voice-props-revert) 'CueVoice "cue")))) (set! main-music (make-sequential-music (list @@ -699,8 +733,7 @@ Syntax: (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))) - + (ly:warning (_ "can't find quoted music `~S'" quoted-name)))) music)) @@ -733,9 +766,41 @@ Syntax: (ly:music-length music)) music) +(define (skip-to-last music parser) + + "Replace MUSIC by + +<< { \\set skipTypesetting = ##t + LENGTHOF(\\showLastLength) + \\set skipTypesetting = ##t } + MUSIC >> + +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 - ;; check-start-chords ; ; no longer needed with chord syntax. (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)) @@ -743,8 +808,13 @@ Syntax: (lambda (music parser) (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes)) music)) + ;; switch-on-debugging - (lambda (x parser) (music-map cue-substitute x)))) + (lambda (x parser) (music-map cue-substitute x)) + + (lambda (x parser) + (skip-to-last x parser) + ))) ;;;;;;;;;;;;;;;;; ;; lyrics @@ -766,12 +836,13 @@ Syntax: (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)) - (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant")) - (cb (ly:grob-property grob 'print-function))) - (if (equal? nm object-name) + (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 - (set! (ly:grob-property grob 'print-function) Balloon_interface::print) - (set! (ly:grob-property grob 'balloon-original-callback) cb) + (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))))))) @@ -870,7 +941,7 @@ use GrandStaff as a context. " '() context)) (else - (ly:warn "Unknown accidental style: ~S" (symbol->string style)) + (ly:warning (_ "unknown accidental style: ~S" style)) (make-sequential-music '())))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -892,3 +963,14 @@ use GrandStaff as a context. " (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) (memq 'note-event (ly:music-property x 'types))) + (ly:music-property event-chord 'elements)))) + + (if (pair? evs) + (ly:music-property (car evs) 'pitch) + #f))) +