X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=7b0d5d0658aead0f69b1da9ad422f46647cce5a3;hb=9e69cb84d6ee5b0a861cd97869b10e3bdf0c833c;hp=0074d3a1f6dd2b99846eab91ef52b517892e0d0d;hpb=74628ba358f39934545ab9b59f1b53e710dd2d35;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 0074d3a1f6..7b0d5d0658 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -3,7 +3,7 @@ ;;;; source file of the GNU LilyPond music typesetter ;;;; ;;;; (c) 1998--2006 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; Han-Wen Nienhuys ;; (use-modules (ice-9 optargs)) @@ -16,15 +16,18 @@ (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 (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 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. @@ -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))) @@ -179,8 +188,8 @@ Returns `obj'. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(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 +202,40 @@ 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" + (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* ((dot? (zero? (modulo times 3))) + (dots (if dot? 1 0)) + (mult (if dot? + (quotient (* times 2) 3) + times)) + (shift (- (ly:intlog2 mult)))) + + (if (memq 'sequential-music (ly:music-property main 'types)) + ;; \repeat "tremolo" { c4 d4 } + (let ((children (length (ly:music-property main 'elements)))) + (if (not (= children 2)) + (ly:warning (_ "expecting 2 elements for chord tremolo, found ~a") children)) + (ly:music-compress r (ly:make-moment 1 children)) + (shift-duration-log r (1- shift) dots)) + ;; \repeat "tremolo" c4 + (shift-duration-log r shift dots))) + r))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. @@ -353,60 +390,19 @@ 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) @@ -426,8 +422,8 @@ OTTAVATION to `8va', or whatever appropriate." (string (cdr (assoc octavation '((2 . "15ma") (1 . "8va") (0 . #f) - (-1 . "8va bassa") - (-2 . "15ma bassa")))))) + (-1 . "8vb") + (-2 . "15mb")))))) (ly:context-set-property! context 'middleCPosition new-c0) (ly:context-set-property! context 'originalCentralCPosition c0) (ly:context-set-property! context 'ottavation string))))) @@ -440,6 +436,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 +460,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 +482,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)) @@ -521,7 +529,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) @@ -603,7 +611,7 @@ SkipEvent. Useful for extracting parts from crowded scores" (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) @@ -668,7 +676,7 @@ without context specification. Called from parser." (defmacro-public def-grace-function (start stop) - `(def-music-function (parser location music) (ly:music?) + `(define-music-function (parser location music) (ly:music?) (make-music 'GraceMusic 'origin location 'element (make-music 'SequentialMusic @@ -676,10 +684,10 @@ 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) @@ -698,7 +706,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 +737,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 (_ "can't find quoted music `~S'" quoted-name)))) music)) @@ -789,12 +801,15 @@ if appropriate. (list (make-sequential-music (list - (context-spec-music (make-property-set 'skipTypesetting #t) 'Score) + (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))) + (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))) @@ -802,7 +817,6 @@ if appropriate. (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) @@ -816,6 +830,7 @@ if appropriate. (skip-to-last x parser) ))) + ;;;;;;;;;;;;;;;;; ;; lyrics @@ -830,23 +845,6 @@ 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 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 @@ -963,3 +961,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))) +