X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=c700f190dbc5f287b2999a6047be3c436e733d0a;hb=af99781b40aed8c6dedbd7d78f1a893355a98e09;hp=0074d3a1f6dd2b99846eab91ef52b517892e0d0d;hpb=74628ba358f39934545ab9b59f1b53e710dd2d35;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 0074d3a1f6..c700f190db 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -2,8 +2,8 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2006 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; (c) 1998--2007 Jan Nieuwenhuizen +;;;; 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))) @@ -177,10 +186,25 @@ Returns `obj'. (newline) obj) +;;; +;;; Scheme music expression --> Lily-syntax-using string translator +;;; +(use-modules (srfi srfi-39) + (scm display-lily)) + +(define*-public (display-lily-music expr parser #:key force-duration) + "Display the music expression using LilyPond syntax" + (memoize-clef-names supported-clefs) + (parameterize ((*indent* 0) + (*previous-duration* (ly:make-duration 2)) + (*force-duration* force-duration)) + (display (music->lily-string expr parser)) + (newline))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(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 +217,43 @@ 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* ((dots (1- (logcount times))) + (mult (/ (* times (ash 1 dots)) (1- (ash 2 dots)))) + (shift (- (ly:intlog2 (floor mult))))) + (if (not (integer? mult)) + (ly:warning (_ "invalid tremolo repeat count: ~a") times)) + (if (memq 'sequential-music (ly:music-property main 'types)) + ;; \repeat "tremolo" { c4 d4 } + (let ((children (length (ly:music-property main 'elements)))) + + ;; fixme: should be more generic. + (if (and (not (= children 2)) + (not (= children 1))) + (ly:warning (_ "expecting 2 elements for chord tremolo, found ~a") children)) + (ly:music-compress r (ly:make-moment 1 children)) + (shift-duration-log r + (if (= children 2) (1- shift) shift) + dots)) + ;; \repeat "tremolo" c4 + (shift-duration-log r shift dots))) + r))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. @@ -285,7 +340,18 @@ i.e. this is not an override" 'grob-property gprop)) (define direction-polyphonic-grobs - '(Stem Tie Rest Slur PhrasingSlur Script TextScript Dots DotColumn Fingering)) + '(DotColumn + Dots + Fingering + LaissezVibrerTie + PhrasingSlur + RepeatTie + Rest + Script + Slur + Stem + TextScript + Tie)) (define-safe-public (make-voice-props-set n) (make-sequential-music @@ -294,6 +360,17 @@ i.e. this is not an override" (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 NoteHead font-size -3) + (Voice Dots font-size -3) + (Voice Stem length-fraction 0.8) + (Voice Stem no-stem-extend #t) + (Voice Beam thickness 0.384) + (Voice Beam length-fraction 0.8) + (Voice Accidental font-size -4))) + (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) @@ -302,8 +379,9 @@ i.e. this is not an override" (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 'MultiMeasureRest 'staff-position))))) + (list (make-property-unset 'graceSettings) + (make-grob-property-revert 'NoteColumn 'horizontal-shift) + (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) (define-safe-public (context-spec-music m context #:optional id) @@ -353,84 +431,39 @@ 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) "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 'middleCPosition)) - (if (= octavation 0) - (let ((where (ly:context-property-where-defined context 'middleCPosition)) - (oc0 (ly:context-property context 'originalCentralCPosition))) - (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 'middleCPosition new-c0) - (ly:context-set-property! context 'originalCentralCPosition c0) - (ly:context-set-property! context 'ottavation string))))) + (if (number? (ly:context-property context 'middleCOffset)) + (let ((where (ly:context-property-where-defined context 'middleCOffset))) + (ly:context-unset-property where 'middleCOffset) + (ly:context-unset-property where 'ottavation))) + + (let* ((offset (* -7 octavation)) + (string (cdr (assoc octavation '((2 . "15ma") + (1 . "8va") + (0 . #f) + (-1 . "8vb") + (-2 . "15mb")))))) + (ly:context-set-property! context 'middleCOffset offset) + (ly:context-set-property! context 'ottavation string) + (ly:set-middle-C! context))) (set! (ly:music-property m 'procedure) ottava-modify) (context-spec-music m 'Staff))) @@ -440,6 +473,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 +497,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 +519,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)) @@ -483,9 +528,9 @@ of beat groupings " 'duration duration 'text string)) -(define-safe-public (make-span-event type spandir) +(define-safe-public (make-span-event type span-dir) (make-music type - 'span-direction spandir)) + 'span-direction span-dir)) (define-public (set-mus-properties! m alist) "Set all of ALIST as properties of M." @@ -521,7 +566,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) @@ -542,9 +587,8 @@ of beat groupings " (define-public (empty-music) (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) @@ -589,45 +633,36 @@ of beat groupings " "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) + (if (memq (ly:music-property mus 'name) '(SkipEvent SkipMusic)) (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) mus)) +(define-public (music-has-type music type) + (memq type (ly:music-property music 'types))) + +(define-public (music-clone music) + (define (alist->args alist acc) + (if (null? alist) + acc + (alist->args (cdr alist) + (cons (caar alist) (cons (cdar alist) acc))))) + + (apply + make-music + (ly:music-property music 'name) + (alist->args (ly:music-mutable-properties music) '()))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. -(define (has-request-chord elts) - (reduce (lambda (x y) (or x y)) #f - (map (lambda (x) - (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:warning 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-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.\nInsert an explicit \\context before chord") - (map check-start-chords es))) - ((equal? name "SequentialMusic") - (if (pair? es) - (check-start-chords (car es)))) - (else (if (ly:music? e) (check-start-chords e))))) - music) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; setting stuff for grace context. @@ -668,7 +703,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 +711,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 +733,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 +764,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 (_ "cannot find quoted music: `~S'") quoted-name))) music)) @@ -789,12 +828,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 +844,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 +857,7 @@ if appropriate. (skip-to-last x parser) ))) + ;;;;;;;;;;;;;;;;; ;; lyrics @@ -830,23 +872,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 @@ -923,11 +948,14 @@ use GrandStaff as a context. " '(Staff (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. ;; Causes accidentals to be printed at every note instead of ;; remembered for the duration of a measure. - ;; accidentals not being remembered, causing accidentals always to be typeset relative to the time signature + ;; accidentals not being remembered, causing accidentals always to + ;; be typeset relative to the time signature + ((equal? style 'forget) (set-accidentals-properties '() '(Staff (same-octave . -1)) @@ -963,3 +991,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))) +