X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=ce4af76c064d378045ce7d305589a00ec5bd74d3;hb=5326fc95f453fca8f75b1540459b066e039f61eb;hp=8c2dc27f9c2b29ad9fcbbd4ff543cdce3fed4195;hpb=834f252cb58c3b1a42dbb387cea7618b87e5bdec;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 8c2dc27f9c..ce4af76c06 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -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:paper-system-property + (make-procedure-with-setter ly:paper-system-property + ly:paper-system-set-property!)) + (define-public (music-map function music) "Apply @var{function} to @var{music} and all of the music it contains. @@ -81,6 +87,96 @@ First it recurses over the children, then the function is applied to MUSIC. (display " }\n") music) +;;; +;;; A scheme music pretty printer +;;; +(define (markup-expression->make-markup markup-expression) + "Transform `markup-expression' into an equivalent, hopefuly readable, scheme expression. +For instance, + \\markup \\bold \\italic hello +==> + (markup #:line (#:bold (#:italic (#:simple \"hello\"))))" + (define (proc->command-keyword proc) + "Return a keyword, eg. `#:bold', from the `proc' function, eg. #" + (let ((cmd-markup (symbol->string (procedure-name proc)))) + (symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-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 + arg))) + (define (inner-markup->make-markup mrkup) + (let ((cmd (proc->command-keyword (car mrkup))) + (args (map transform-arg (cdr mrkup)))) + `(,cmd ,@args))) + ;; body: + (if (string? markup-expression) + markup-expression + `(markup ,@(inner-markup->make-markup markup-expression)))) + +(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) + (markup-expression->make-markup obj)) + (;; music expression + (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) + `(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) + `(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) + `'()) + (else + 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. + +Returns `obj'. +" + (pretty-print (music->make-music obj) port) + (newline) + obj) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (shift-one-duration-log music shift dot) @@ -123,14 +219,20 @@ First it recurses over the children, then the function is applied to MUSIC. (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)) @@ -144,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) @@ -183,7 +280,7 @@ 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)) @@ -270,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) @@ -413,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))) @@ -463,9 +576,10 @@ 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)) @@ -482,7 +596,7 @@ of beat groupings " (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), @@ -585,9 +699,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 @@ -608,8 +722,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)) @@ -642,9 +755,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)) @@ -652,8 +797,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 @@ -675,12 +825,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 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))))))) @@ -779,7 +930,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 '())))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;