From 342fabd2d06666257dd41c8d38e8682949a04f36 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sat, 28 Feb 2004 10:54:00 +0000 Subject: [PATCH] * lily/beam-quanting.cc: cleanup, separate counts for left and right beam ends. * lily/side-position-interface.cc (quantised_position): also quantize staccato position for forced stem directions. --- ChangeLog | 17 + .../regression/spacing-accidental-stretch.ly | 4 +- input/regression/staccato-pos.ly | 4 +- input/test/nested-groups.ly | 1 + lily/beam-quanting.cc | 76 +- lily/include/beam.hh | 2 +- lily/side-position-interface.cc | 12 +- make/lilypond.redhat.spec.in | 6 +- scm/chord-entry.scm | 267 ++--- scm/clef.scm | 30 +- scm/music-functions.scm | 919 +++++++----------- scm/part-combiner.scm | 789 ++++++--------- 12 files changed, 845 insertions(+), 1282 deletions(-) diff --git a/ChangeLog b/ChangeLog index 57837b8705..7ab737f280 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2004-02-28 Han-Wen Nienhuys + + * lily/beam-quanting.cc: cleanup, separate counts for left and + right beam ends. + + * lily/side-position-interface.cc (quantised_position): also + quantize staccato position for forced stem directions. + +2004-02-27 Han-Wen Nienhuys + + * scm/*.scm: Patch by Nicolas Sceaux: + + * scm/music-functions.scm: ly:grob-property and ly:music-property + are made procedure with setters. + + * scm/*.scm: replace ..-set-property! with set! (..-property ) + 2004-02-28 Heikki Junes * input/test/[p-r]*.ly: use more verbose texidocs. add comments diff --git a/input/regression/spacing-accidental-stretch.ly b/input/regression/spacing-accidental-stretch.ly index bffac60ea7..d87fb89d36 100644 --- a/input/regression/spacing-accidental-stretch.ly +++ b/input/regression/spacing-accidental-stretch.ly @@ -2,7 +2,9 @@ \version "2.1.26" \header { - texidoc = "Accidentals do not influence the amount of stretchable space. " + texidoc = "Accidentals do not influence the amount of stretchable space. +The accidental does add a little non-stretchable space. +" } \score { diff --git a/input/regression/staccato-pos.ly b/input/regression/staccato-pos.ly index 50f16785a2..953a3d5a0a 100644 --- a/input/regression/staccato-pos.ly +++ b/input/regression/staccato-pos.ly @@ -9,7 +9,9 @@ not be on staff lines. } \score { \context Voice \notes\relative c' { - e'4-. f-. d-. c-. b-. + e'4-. f-. d-. c-. b-. + \stemDown + e,-. d-. c-. b-. a-. g-. } \paper { raggedright = ##t diff --git a/input/test/nested-groups.ly b/input/test/nested-groups.ly index 6db3382580..519da6c6d7 100644 --- a/input/test/nested-groups.ly +++ b/input/test/nested-groups.ly @@ -7,6 +7,7 @@ and @code{ChoirStaff} produce similar straight brackets, whereas and @code{InnerChoirStaff}, the brackets are shifted leftwards. " +} \score { \notes << diff --git a/lily/beam-quanting.cc b/lily/beam-quanting.cc index 24b8599e31..a1fb2a94b8 100644 --- a/lily/beam-quanting.cc +++ b/lily/beam-quanting.cc @@ -238,7 +238,13 @@ Beam::quanting (SCM smob) } Real rad = Staff_symbol_referencer::staff_radius (me); - int beam_count = get_beam_count (me); + + + + Drul_array edge_beam_counts + (Stem::beam_multiplicity (stems[0]).length () + 1, + Stem::beam_multiplicity (stems.top ()).length () + 1); + Real beam_translation = get_beam_translation (me) / ss; Real reasonable_score = (is_knee) ? 200000 : 100; @@ -247,7 +253,7 @@ Beam::quanting (SCM smob) { Real d = score_forbidden_quants (qscores[i].yl, qscores[i].yr, rad, slt, thickness, beam_translation, - beam_count, ldir, rdir); + edge_beam_counts, ldir, rdir); qscores[i].demerits += d; #if DEBUG_QUANTING @@ -438,14 +444,14 @@ Beam::score_forbidden_quants (Real yl, Real yr, Real radius, Real slt, Real thickness, Real beam_translation, - int beam_count, + Drul_array beam_counts, Direction ldir, Direction rdir) { Real dy = yr - yl; Drul_array y(yl,yr); Drul_array dirs(ldir,rdir); - Real extra_demerit = SECONDARY_BEAM_DEMERIT / beam_count; + Real extra_demerit = SECONDARY_BEAM_DEMERIT / (beam_counts[LEFT] >? beam_counts[RIGHT]); /* Inside the staff, inter quants are forbidden. @@ -460,9 +466,9 @@ Beam::score_forbidden_quants (Real yl, Real yr, while ((flip (&d))!= LEFT); - for (int j = 1; j <= beam_count; j++) + do { - do + for (int j = 1; j <= beam_counts[d]; j++) { /* see if the outer staffline falls in a beam-gap @@ -482,66 +488,46 @@ Beam::score_forbidden_quants (Real yl, Real yr, if (gap.contains (k)) dem += extra_demerit; } - while ((flip (&d))!= LEFT); } + while ((flip (&d))!= LEFT); - - // todo: use beam_count of outer stems. - if (beam_count >= 2) + if ((beam_counts[LEFT] >? beam_counts[RIGHT]) >= 2) { Real straddle = 0.0; Real sit = (thickness - slt) / 2; Real inter = 0.5; Real hang = 1.0 - (thickness - slt) / 2; - // hmm, without Interval/Drul_array, you get ~ 4x same code... - if (fabs (y[LEFT] - dirs[LEFT] * beam_translation) < radius + inter) - { - if (dirs[LEFT] == UP && dy <= BEAM_EPS - && fabs (my_modf (y[LEFT]) - sit) < BEAM_EPS) - dem += extra_demerit; - - if (dirs[LEFT] == DOWN && dy >= BEAM_EPS - && fabs (my_modf (y[LEFT]) - hang) < BEAM_EPS) - dem += extra_demerit; - } - if (fabs (y[RIGHT] - dirs[RIGHT] * beam_translation) < radius + inter) - { - if (dirs[RIGHT] == UP && dy >= BEAM_EPS - && fabs (my_modf (y[RIGHT]) - sit) < BEAM_EPS) - dem += extra_demerit; - - if (dirs[RIGHT] == DOWN && dy <= BEAM_EPS - && fabs (my_modf (y[RIGHT]) - hang) < BEAM_EPS) - dem += extra_demerit; - } - - if (beam_count >= 3) + Direction d = LEFT; + do { - if (fabs (y[LEFT] - 2 * dirs[LEFT] * beam_translation) < radius + inter) + if (beam_counts[d] >= 2 + && fabs (y[d] - dirs[d] * beam_translation) < radius + inter) { - if (dirs[LEFT] == UP && dy <= BEAM_EPS - && fabs (my_modf (y[LEFT]) - straddle) < BEAM_EPS) + if (dirs[d] == UP && dy <= BEAM_EPS + && fabs (my_modf (y[d]) - sit) < BEAM_EPS) dem += extra_demerit; - - if (dirs[LEFT] == DOWN && dy >= BEAM_EPS - && fabs (my_modf (y[LEFT]) - straddle) < BEAM_EPS) + + if (dirs[d] == DOWN && dy >= BEAM_EPS + && fabs (my_modf (y[d]) - hang) < BEAM_EPS) dem += extra_demerit; } - - if (fabs (y[RIGHT] - 2 * dirs[RIGHT] * beam_translation) < radius + inter) + + if (beam_counts[d] >= 3 + && fabs (y[d] - 2 * dirs[d] * beam_translation) < radius + inter) { - if (dirs[RIGHT] == UP && dy >= BEAM_EPS - && fabs (my_modf (y[RIGHT]) - straddle) < BEAM_EPS) + if (dirs[d] == UP && dy <= BEAM_EPS + && fabs (my_modf (y[d]) - straddle) < BEAM_EPS) dem += extra_demerit; - if (dirs[RIGHT] == DOWN && dy <= BEAM_EPS - && fabs (my_modf (y[RIGHT]) - straddle) < BEAM_EPS) + if (dirs[d] == DOWN && dy >= BEAM_EPS + && fabs (my_modf (y[d]) - straddle) < BEAM_EPS) dem += extra_demerit; } } + while (flip (&d) != LEFT); } return dem; diff --git a/lily/include/beam.hh b/lily/include/beam.hh index cb7ec49247..e7594f5a4d 100644 --- a/lily/include/beam.hh +++ b/lily/include/beam.hh @@ -56,7 +56,7 @@ public: Real yl, Real yr); static Real score_forbidden_quants (Real, Real, Real, Real, Real, Real, - int, Direction, Direction); + Drul_array, Direction, Direction); static int get_direction_beam_count (Grob *me, Direction d); diff --git a/lily/side-position-interface.cc b/lily/side-position-interface.cc index 7dbff769cc..4f75f099bd 100644 --- a/lily/side-position-interface.cc +++ b/lily/side-position-interface.cc @@ -8,6 +8,7 @@ */ #include // ceil. +#include "note-head.hh" #include "side-position-interface.hh" #include "warn.hh" #include "warn.hh" @@ -170,12 +171,19 @@ Side_position_interface::quantised_position (SCM element_smob, SCM) Real rad = Staff_symbol_referencer::staff_radius (me) *2 ; int ip = int (rp); - if (abs (ip) <= rad && Staff_symbol_referencer::on_staffline (me,ip)) + Grob *head = me->get_parent (X_AXIS); + + if (Staff_symbol_referencer::on_staffline (me,ip) + && ((abs (ip) <= rad) + || (Note_head::has_interface (head) + && sign (Staff_symbol_referencer::get_position (head)) + == -d) + )) { ip += d; rp += d; } - + return gh_double2scm ((rp - p) * Staff_symbol_referencer::staff_space (me) / 2.0); } return gh_double2scm (0.0); diff --git a/make/lilypond.redhat.spec.in b/make/lilypond.redhat.spec.in index b147e442f1..67261ab838 100644 --- a/make/lilypond.redhat.spec.in +++ b/make/lilypond.redhat.spec.in @@ -97,6 +97,9 @@ rm `find /var/lib/texmf -name 'feta*pk' -or -name 'feta*tfm' -or -name 'parmesan echo 'Please logout first before using LilyPond.' %preun +if [ -f /usr/share/lilypond/%{version}/ls-R ]; then + rm -f /usr/share/lilypond/%{version}/ls-R +fi %if %{info} @@ -107,9 +110,6 @@ echo 'Please logout first before using LilyPond.' # chkfontpath --remove=%{_datadir}/share/lilypond/@TOPLEVEL_VERSION@/fonts/type1/ %postun -if [ -f /usr/share/lilypond/%{version}/ls-R ]; then - rm -f /usr/share/lilypond/%{version}/ls-R -fi %post documentation scrollkeeper-update diff --git a/scm/chord-entry.scm b/scm/chord-entry.scm index bc408de71f..068078db96 100644 --- a/scm/chord-entry.scm +++ b/scm/chord-entry.scm @@ -4,7 +4,6 @@ ;;; (define-public (construct-chord root duration modifications) - " Build a chord on root using modifiers in MODIFICATIONS. NoteEvent have duration DURATION.. @@ -13,84 +12,64 @@ Notes: natural 11 is left from chord if not explicitly specified. Entry point for the parser. " - (let* - ((flat-mods (flatten-list modifications)) - (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) - (complete-chord '()) - (bass #f) - (inversion #f) - (lead-mod #f) - (explicit-11 #f) - (start-additions #t)) + (let* ((flat-mods (flatten-list modifications)) + (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) + (complete-chord '()) + (bass #f) + (inversion #f) + (lead-mod #f) + (explicit-11 #f) + (start-additions #t)) (define (interpret-inversion chord mods) "Read /FOO part. Side effect: INVERSION is set." - (if (and (> (length mods) 1) (eq? (car mods) 'chord-slash)) (begin (set! inversion (cadr mods)) (set! mods (cddr mods)))) - (interpret-bass chord mods)) (define (interpret-bass chord mods) "Read /+FOO part. Side effect: BASS is set." - (if (and (> (length mods) 1) (eq? (car mods) 'chord-bass)) (begin (set! bass (cadr mods)) (set! mods (cddr mods)))) - (if (pair? mods) - (scm-error 'chord-format "construct-chord" "Spurious garbage following chord: ~A" mods #f) - ) + (scm-error 'chord-format "construct-chord" "Spurious garbage following chord: ~A" mods #f)) + chord) - chord - ) - - (define (interpret-removals chord mods) + (define (interpret-removals chord mods) (define (inner-interpret chord mods) (if (and (pair? mods) (ly:pitch? (car mods))) - (inner-interpret - (remove-step (+ 1 (ly:pitch-steps (car mods))) chord) - (cdr mods)) - (interpret-inversion chord mods)) - ) - + (inner-interpret (remove-step (+ 1 (ly:pitch-steps (car mods))) chord) + (cdr mods)) + (interpret-inversion chord mods))) (if (and (pair? mods) (eq? (car mods) 'chord-caret)) (inner-interpret chord (cdr mods)) - (interpret-inversion chord mods)) - - ) + (interpret-inversion chord mods))) (define (interpret-additions chord mods) "Interpret additions. TODO: should restrict modifier use?" - - (cond - ((null? mods) chord) - ((ly:pitch? (car mods)) - (if (= (pitch-step (car mods)) 11) - (set! explicit-11 #t)) - (interpret-additions - (cons (car mods) (remove-step (pitch-step (car mods)) chord)) - (cdr mods))) - ((procedure? (car mods)) - (interpret-additions - ((car mods) chord) - (cdr mods))) - (else (interpret-removals chord mods)) - )) + (cond ((null? mods) chord) + ((ly:pitch? (car mods)) + (if (= (pitch-step (car mods)) 11) + (set! explicit-11 #t)) + (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord)) + (cdr mods))) + ((procedure? (car mods)) + (interpret-additions ((car mods) chord) + (cdr mods))) + (else (interpret-removals chord mods)))) (define (pitch-octavated-strictly-below p root) - "return P, but octavated, so it is below ROOT" - (ly:make-pitch - (+ - (ly:pitch-octave root) - (if (> (ly:pitch-notename root) - (ly:pitch-notename p)) - 0 -1)) - (ly:pitch-notename p) - (ly:pitch-alteration p))) + "return P, but octavated, so it is below ROOT" + (ly:make-pitch (+ (ly:pitch-octave root) + (if (> (ly:pitch-notename root) + (ly:pitch-notename p)) + 0 -1)) + (ly:pitch-notename p) + (ly:pitch-alteration p))) (define (process-inversion complete-chord) "Take out inversion from COMPLETE-CHORD, and put it at the bottom. @@ -101,105 +80,71 @@ If INVERSION is not in COMPLETE-CHORD, it will be set as a BASS, overriding the bass specified. " - (let* - ( - (root (car complete-chord)) - (inv? (lambda (y) - (and (= (ly:pitch-notename y) - (ly:pitch-notename inversion)) - (= (ly:pitch-alteration y) - (ly:pitch-alteration inversion)) - ))) - - (rest-of-chord (remove inv? complete-chord)) - (inversion-candidates (filter inv? complete-chord)) - (down-inversion (pitch-octavated-strictly-below inversion root)) - ) - + (let* ((root (car complete-chord)) + (inv? (lambda (y) + (and (= (ly:pitch-notename y) + (ly:pitch-notename inversion)) + (= (ly:pitch-alteration y) + (ly:pitch-alteration inversion))))) + (rest-of-chord (remove inv? complete-chord)) + (inversion-candidates (filter inv? complete-chord)) + (down-inversion (pitch-octavated-strictly-below inversion root))) (if (pair? inversion-candidates) (set! inversion (car inversion-candidates)) (begin (set! bass inversion) - (set! inversion #f)) - ) + (set! inversion #f))) (if inversion (cons down-inversion rest-of-chord) - rest-of-chord - ) - )) - + rest-of-chord))) ;; root is always one octave too low. - - ; something weird happens when this is removed, - ; every other chord is octavated. --hwn... hmmm. + ;; something weird happens when this is removed, + ;; every other chord is octavated. --hwn... hmmm. (set! root (ly:pitch-transpose root (ly:make-pitch 1 0 0))) - ;; skip the leading : , we need some of the stuff following it. (if (pair? flat-mods) (if (eq? (car flat-mods) 'chord-colon) (set! flat-mods (cdr flat-mods)) - (set! start-additions #f) - )) - + (set! start-additions #f))) ;; remember modifier (if (and (pair? flat-mods) (procedure? (car flat-mods))) (begin (set! lead-mod (car flat-mods)) - (set! flat-mods (cdr flat-mods)) - )) - - - + (set! flat-mods (cdr flat-mods)))) ;; extract first number if present, and build pitch list. (if (and (pair? flat-mods) - (ly:pitch? (car flat-mods)) - (not (eq? lead-mod sus-modifier)) - ) - + (ly:pitch? (car flat-mods)) + (not (eq? lead-mod sus-modifier))) (begin (if (= (pitch-step (car flat-mods)) 11) (set! explicit-11 #t)) (set! base-chord (stack-thirds (car flat-mods) the-canonical-chord)) - (set! flat-mods (cdr flat-mods)) - )) - + (set! flat-mods (cdr flat-mods)))) ;; apply modifier (if (procedure? lead-mod) (set! base-chord (lead-mod base-chord))) - (set! complete-chord (if start-additions - (interpret-additions base-chord flat-mods) - (interpret-removals base-chord flat-mods) - )) - + (interpret-additions base-chord flat-mods) + (interpret-removals base-chord flat-mods))) (set! complete-chord (sort complete-chord ly:pitch= n 8) - (ly:make-pitch 1 (- n 8) (nca n)) - (ly:make-pitch 0 (- n 1) (nca n)))) - '(1 3 5 7 9 11 13))) + (map (lambda (n) + (define (nca x) + (if (= x 7) FLAT 0)) + (if (>= n 8) + (ly:make-pitch 1 (- n 8) (nca n)) + (ly:make-pitch 0 (- n 1) (nca n)))) + '(1 3 5 7 9 11 13))) (define (stack-thirds upper-step base) "Stack thirds listed in BASE until we reach UPPER-STEP. Add UPPER-STEP separately." - (cond - ((null? base) '()) - ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) - (cons (car base) (stack-thirds upper-step (cdr base)))) - ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) - (list upper-step)) - (else '()) - )) - + (cond ((null? base) '()) + ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) + (cons (car base) (stack-thirds upper-step (cdr base)))) + ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) + (list upper-step)) + (else '()))) diff --git a/scm/clef.scm b/scm/clef.scm index 6e0cff1f67..5634abe905 100644 --- a/scm/clef.scm +++ b/scm/clef.scm @@ -94,39 +94,31 @@ "Generate the clef setting commands for a clef with name CL." (define (make-prop-set props) (let ((m (make-music-by-name 'PropertySet))) - - (map (lambda (x) (ly:music-set-property! m (car x) (cdr x))) props) + (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props) m)) - (let ((e '()) (c0 0) (oct 0) (match (string-match "^(.*)([_^])([0-9]+)$" clef-name))) - (if match (begin (set! clef-name (match:substring match 1)) (set! oct (* (if (equal? (match:substring match 2) "^") -1 1) (- (string->number (match:substring match 3)) 1))))) - - (set! e (assoc clef-name supported-clefs)) - + (set! e (assoc clef-name supported-clefs)) (if (pair? e) - (let* ((musics - (map make-prop-set - `(((symbol . clefGlyph) - (value . ,(cadr e))) - ((symbol . centralCPosition) - (value . ,(+ oct - (caddr e) - (cdr (assoc (cadr e) c0-pitch-alist))))) - ((symbol . clefPosition) (value . ,(caddr e))) - ((symbol . clefOctavation) (value . ,(- oct)))))) + (let* ((musics (map make-prop-set + `(((symbol . clefGlyph) (value . ,(cadr e))) + ((symbol . centralCPosition) + (value . ,(+ oct + (caddr e) + (cdr (assoc (cadr e) c0-pitch-alist))))) + ((symbol . clefPosition) (value . ,(caddr e))) + ((symbol . clefOctavation) (value . ,(- oct)))))) (seq (make-music-by-name 'SequentialMusic)) (csp (make-music-by-name 'ContextSpeccedMusic))) - - (ly:music-set-property! seq 'elements musics) + (set! (ly:music-property seq 'elements) musics) (context-spec-music seq 'Staff)) (begin (ly:warn (format "Unknown clef type `~a' diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 245eb518a6..3ef7eccc66 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -1,17 +1,28 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ly:music-property with setter +;;; (ly:music-property my-music 'elements) +;;; ==> the 'elements property +;;; (set! (ly:music-property my-music 'elements) value) +;;; ==> set the 'elements property and return it +(define-public ly:music-property + (make-procedure-with-setter ly:music-property + ly:music-set-property!)) + +(define-public ly:grob-property + (make-procedure-with-setter ly:grob-property + ly:grob-set-property!)) + (define-public (music-map function music) "Apply @var{function} to @var{music} and all of the music it contains. " - (let* ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element)) - ) - - (ly:music-set-property! music 'elements - (map (lambda (y) (music-map function y)) es)) - (if (ly:music? e) - (ly:music-set-property! music 'element (music-map function e))) - (function music) - )) + (let ((es (ly:music-property music 'elements)) + (e (ly:music-property music 'element))) + (set! (ly:music-property music 'elements) + (map (lambda (y) (music-map function y)) es)) + (if (ly:music? e) + (set! (ly:music-property music 'element) + (music-map function e))) + (function music))) (define-public (music-filter pred? music) "Filter out music expressions that do not satisfy PRED." @@ -25,27 +36,22 @@ (filtered-e (if (ly:music? e) (inner-music-filter pred? e) e)) - (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es))) - ) - - (ly:music-set-property! music 'element filtered-e) - (ly:music-set-property! music 'elements filtered-es) - (ly:music-set-property! music 'articulations filtered-as) - + (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es)))) + (set! (ly:music-property music 'element) filtered-e) + (set! (ly:music-property music 'elements) filtered-es) + (set! (ly:music-property music 'articulations) filtered-as) ;; if filtering emptied the expression, we remove it completely. (if (or (pred? music) (and (eq? filtered-es '()) (not (ly:music? e)) (or (not (eq? es '())) (ly:music? e)))) (set! music '())) - music)) (set! music (inner-music-filter pred? music)) (if (ly:music? music) music - (make-music-by-name 'Music) ;must return music. - )) + (make-music-by-name 'Music))) ;must return music. (define-public (remove-tag tag) (lambda (mus) @@ -53,38 +59,26 @@ (lambda (m) (let* ((tags (ly:music-property m 'tags)) (res (memq tag tags))) - res)) mus))) + res)) + mus))) (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)) - (e (ly:music-property music 'element)) - ) - + (display ": { ") + (let ((es (ly:music-property music 'elements)) + (e (ly:music-property music 'element))) (display (ly:get-mutable-properties music)) - - (if (pair? es) + (if (pair? es) (begin (display "\nElements: {\n") (map display-music es) - (display "}\n") - )) - - + (display "}\n"))) (if (ly:music? e) (begin (display "\nChild:") - (display-music e) - ) - ) - ) + (display-music e)))) (display " }\n") - music - ) - - + music) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -93,22 +87,14 @@ " add SHIFT to ly:duration-log 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)) - ) + (let ((d (ly:music-property music 'duration))) (if (ly:duration? d) - (let* ( - (cp (ly:duration-factor d)) + (let* ((cp (ly:duration-factor d)) (nd (ly:make-duration (+ shift (ly:duration-log d)) (+ dot (ly:duration-dot-count d)) (car cp) - (cdr cp))) - - ) - (ly:music-set-property! music 'duration nd) - )) + (cdr cp)))) + (set! (ly:music-property music 'duration) nd))) music)) @@ -124,11 +110,12 @@ (define-public (note-to-cluster music) "Replace NoteEvents by ClusterNoteEvents." (if (eq? (ly:music-property music 'name) 'NoteEvent) - (let* ((cn (make-music-by-name 'ClusterNoteEvent))) - - (ly:music-set-property! cn 'pitch (ly:music-property music 'pitch)) - (ly:music-set-property! cn 'duration (ly:music-property music 'duration)) - cn) + (let ((cn (make-music-by-name 'ClusterNoteEvent))) + (set! (ly:music-property cn 'pitch) + (ly:music-property music 'pitch)) + (set! (ly:music-property cn 'duration) + (ly:music-property music 'duration)) + cn) music)) (define-public (notes-to-clusters music) @@ -138,37 +125,29 @@ ;; repeats. (define-public (unfold-repeats music) -" + " This function replaces all repeats with unfold repeats. It was written by Rune Zedeler. " - (let* ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element)) - (n (ly:music-name music))) - + (let ((es (ly:music-property music 'elements)) + (e (ly:music-property music 'element)) + (n (ly:music-name music))) (if (equal? n "Repeated_music") - (begin - (if (equal? - (ly:music-property music 'iterator-ctor) - Chord_tremolo_iterator::constructor) - (shift-duration-log music (ly:intlog2 (ly:music-property music 'repeat-count)) 0) - ) - (ly:music-set-property! - music 'length Repeated_music::unfolded_music_length) - (ly:music-set-property! - music 'start-moment-function Repeated_music::first_start) - (ly:music-set-property! - music 'iterator-ctor Unfolded_repeat_iterator::constructor))) - + (begin + (if (equal? (ly:music-property music 'iterator-ctor) + Chord_tremolo_iterator::constructor) + (shift-duration-log music (ly:intlog2 (ly:music-property music 'repeat-count)) 0)) + (set! (ly:music-property music 'length) + Repeated_music::unfolded_music_length) + (set! (ly:music-property music 'start-moment-function) + Repeated_music::first_start) + (set! (ly:music-property music 'iterator-ctor) + Unfolded_repeat_iterator::constructor))) (if (pair? es) - (ly:music-set-property! - music 'elements - (map unfold-repeats es))) - + (set! (ly:music-property music 'elements) + (map unfold-repeats es))) (if (ly:music? e) - (ly:music-set-property! - music 'element - (unfold-repeats e))) - + (set! (ly:music-property music 'element) + (unfold-repeats e))) music)) @@ -176,143 +155,102 @@ written by Rune Zedeler. " ;; property setting music objs. (define-public (make-grob-property-set grob gprop val) - "Make a Music expression that sets GPROP to VAL in GROB. Does a pop first, i.e. this is not an override" - - (let* ((m (make-music-by-name 'OverrideProperty))) - (ly:music-set-property! m 'symbol grob) - (ly:music-set-property! m 'grob-property gprop) - (ly:music-set-property! m 'grob-value val) - (ly:music-set-property! m 'pop-first #t) - - m - - )) -(define-public (make-grob-property-override grob gprop val) + (let ((m (make-music-by-name 'OverrideProperty))) + (set! (ly:music-property m 'symbol) grob) + (set! (ly:music-property m 'grob-property) gprop) + (set! (ly:music-property m 'grob-value) val) + (set! (ly:music-property m 'pop-first) #t) + m)) +(define-public (make-grob-property-override grob gprop val) "Make a Music expression that sets GPROP to VAL in GROB. Does a pop first, i.e. this is not an override" - - (let* ((m (make-music-by-name 'OverrideProperty))) - (ly:music-set-property! m 'symbol grob) - (ly:music-set-property! m 'grob-property gprop) - (ly:music-set-property! m 'grob-value val) - - m - - )) - + (let ((m (make-music-by-name 'OverrideProperty))) + (set! (ly:music-property m 'symbol) grob) + (set! (ly:music-property m 'grob-property) gprop) + (set! (ly:music-property m 'grob-value) val) + m)) (define-public (make-grob-property-revert grob gprop) "Revert the grob property GPROP for GROB." (let* ((m (make-music-by-name 'OverrideProperty))) - (ly:music-set-property! m 'symbol grob) - (ly:music-set-property! m 'grob-property gprop) - - m - - )) + (set! (ly:music-property m 'symbol) grob) + (set! (ly:music-property m 'grob-property) gprop) + m)) (define direction-polyphonic-grobs - '(Tie Rest Slur Script TextScript Stem Dots DotColumn)) + '(Tie Rest Slur Script TextScript Stem Dots DotColumn)) (define-public (make-voice-props-set n) (make-sequential-music (append - (map (lambda (x) (make-grob-property-set x 'direction - (if (odd? n) -1 1))) - direction-polyphonic-grobs) - (list - (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-set 'MultiMeasureRest 'staff-position - (if (odd? n) -4 4) - ) - - ) - ) - )) + (map (lambda (x) (make-grob-property-set x 'direction + (if (odd? n) -1 1))) + direction-polyphonic-grobs) + (list (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) + (make-grob-property-set 'MultiMeasureRest 'staff-position + (if (odd? n) -4 4)))))) (define-public (make-voice-props-revert) (make-sequential-music (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 'NoteColumn 'horizontal-shift))))) (define-public (context-spec-music m context . rest) "Add \\context CONTEXT = foo to M. " - - (let* ((cm (make-music-by-name 'ContextSpeccedMusic))) - (ly:music-set-property! cm 'element m) - (ly:music-set-property! cm 'context-type context) + (let ((cm (make-music-by-name 'ContextSpeccedMusic))) + (set! (ly:music-property cm 'element) m) + (set! (ly:music-property cm 'context-type) context) (if (and (pair? rest) (string? (car rest))) - (ly:music-set-property! cm 'context-id (car rest)) - ) - cm - )) + (set! (ly:music-property cm 'context-id) (car rest))) + cm)) (define-public (make-apply-context func) - (let* - ((m (make-music-by-name 'ApplyContext))) - - (ly:music-set-property! m 'procedure func) - m - )) + (let ((m (make-music-by-name 'ApplyContext))) + (set! (ly:music-property m 'procedure) func) + m)) (define-public (make-sequential-music elts) - (let* ((m (make-music-by-name 'SequentialMusic))) - (ly:music-set-property! m 'elements elts) - m - )) + (let ((m (make-music-by-name 'SequentialMusic))) + (set! (ly:music-property m 'elements) elts) + m)) (define-public (make-simultaneous-music elts) - (let* ((m (make-music-by-name 'SimultaneousMusic))) - (ly:music-set-property! m 'elements elts) - m - )) + (let ((m (make-music-by-name 'SimultaneousMusic))) + (set! (ly:music-property m 'elements) elts) + m)) (define-public (make-event-chord elts) - (let* ((m (make-music-by-name 'EventChord))) - (ly:music-set-property! m 'elements elts) - m - )) - + (let ((m (make-music-by-name 'EventChord))) + (set! (ly:music-property m 'elements) elts) + m)) (define-public (make-skip-music dur) - (let* ((m (make-music-by-name 'SkipMusic))) - (ly:music-set-property! m 'duration dur) - m - )) + (let ((m (make-music-by-name 'SkipMusic))) + (set! (ly:music-property m 'duration) dur) + m)) ;;;;;;;;;;;;;;;; ;; mmrest (define-public (make-multi-measure-rest duration location) - (let* - ( - (start (make-music-by-name 'MultiMeasureRestEvent)) - (ch (make-music-by-name 'BarCheck)) - (ch2 (make-music-by-name 'BarCheck)) - (seq (make-music-by-name 'MultiMeasureRestMusicGroup)) - ) - - (map (lambda (x) (ly:music-set-property! x 'origin location)) + (let ((start (make-music-by-name 'MultiMeasureRestEvent)) + (ch (make-music-by-name 'BarCheck)) + (ch2 (make-music-by-name 'BarCheck)) + (seq (make-music-by-name 'MultiMeasureRestMusicGroup))) + (map (lambda (x) (set! (ly:music-property x 'origin) location)) (list start ch ch2 seq)) - (ly:music-set-property! start 'duration duration) - (ly:music-set-property! seq 'elements - (list - ch - (make-event-chord (list start)) - ch2 - )) - - seq - )) + (set! (ly:music-property start 'duration) duration) + (set! (ly:music-property seq 'elements) + (list ch + (make-event-chord (list start)) + ch2)) + seq)) (define-public (glue-mm-rest-texts music) "Check if we have R1*4-\\markup { .. }, and if applicable convert to @@ -320,91 +258,58 @@ a property set for MultiMeasureRestNumber." (define (script-to-mmrest-text script-music) "Extract 'direction and 'text from SCRIPT-MUSIC, and transform into property sets." - - (let* - ( - (text (ly:music-property script-music 'text)) - (dir (ly:music-property script-music 'direction)) - (p (make-music-by-name 'MultiMeasureTextEvent)) - ) - + (let ((text (ly:music-property script-music 'text)) + (dir (ly:music-property script-music 'direction)) + (p (make-music-by-name 'MultiMeasureTextEvent))) (if (ly:dir? dir) - (ly:music-set-property! p 'direction dir)) - (ly:music-set-property! p 'text text) - p - )) + (set! (ly:music-property p 'direction) dir)) + (set! (ly:music-property p 'text) text) + 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 (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) - (ly:music-set-property! - music 'elements - (cons (make-event-chord texts) others) - )) - )) - music - ) + (set! (ly:music-property music 'elements) + (cons (make-event-chord texts) others))))) + music) (define-public (make-property-set sym val) - (let* - ( - (m (make-music-by-name 'PropertySet)) - ) - (ly:music-set-property! m 'symbol sym) - (ly:music-set-property! m 'value val) - m - )) - - + (let ((m (make-music-by-name 'PropertySet))) + (set! (ly:music-property m 'symbol) sym) + (set! (ly:music-property m 'value) val) + m)) (define-public (make-ottava-set octavation) - (let* - ((m (make-music-by-name 'ApplyContext))) + (let ((m (make-music-by-name 'ApplyContext))) - - (define (ottava-modify context) - "Either reset centralCPosition to the stored original, or remember + (define (ottava-modify context) + "Either reset centralCPosition to the stored original, or remember old centralCPosition, add OCTAVATION to centralCPosition, and set -OTTAVATION to `8va', or whatever appropriate." - - (if (number? (ly:context-property context 'centralCPosition)) - - (if (= octavation 0) - (let* - ((where (ly:context-property-where-defined context 'centralCPosition)) - (oc0 (ly:context-property context 'originalCentralCPosition))) - - (ly:context-set-property! context 'centralCPosition oc0) - (ly:unset-context-property where 'originalCentralCPosition) - (ly:unset-context-property where 'ottavation)) - - (let* - ((where (ly:context-property-where-defined context 'centralCPosition)) - (c0 (ly:context-property context 'centralCPosition)) - (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 'centralCPosition new-c0) - (ly:context-set-property! context 'originalCentralCPosition c0) - (ly:context-set-property! context 'ottavation string) - - )))) - - (ly:music-set-property! m 'procedure ottava-modify) - (context-spec-music m 'Staff) - )) +OTTAVATION to `8va', or whatever appropriate." + (if (number? (ly:context-property context 'centralCPosition)) + (if (= octavation 0) + (let ((where (ly:context-property-where-defined context 'centralCPosition)) + (oc0 (ly:context-property context 'originalCentralCPosition))) + (ly:context-set-property! context 'centralCPosition oc0) + (ly:unset-context-property where 'originalCentralCPosition) + (ly:unset-context-property where 'ottavation)) + (let* ((where (ly:context-property-where-defined context 'centralCPosition)) + (c0 (ly:context-property context 'centralCPosition)) + (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 'centralCPosition new-c0) + (ly:context-set-property! context 'originalCentralCPosition c0) + (ly:context-set-property! context 'ottavation string))))) + (set! (ly:music-property m 'procedure) ottava-modify) + (context-spec-music m 'Staff))) (define-public (set-octavation ottavation) (ly:export (make-ottava-set ottavation))) @@ -414,91 +319,67 @@ OTTAVATION to `8va', or whatever appropriate." Rest can contain a list of beat groupings " - - (let* - ( - (set1 (make-property-set 'timeSignatureFraction (cons num den) )) - (beat (ly:make-moment 1 den)) - (len (ly:make-moment num den)) - (set2 (make-property-set 'beatLength beat)) - (set3 (make-property-set 'measureLength len)) - (set4 (make-property-set 'beatGrouping (if (pair? rest) - (car rest) - '()))) - (basic (list set1 set2 set3 set4))) - + (let* ((set1 (make-property-set 'timeSignatureFraction (cons num den))) + (beat (ly:make-moment 1 den)) + (len (ly:make-moment num den)) + (set2 (make-property-set 'beatLength beat)) + (set3 (make-property-set 'measureLength len)) + (set4 (make-property-set 'beatGrouping (if (pair? rest) + (car rest) + '()))) + (basic (list set1 set2 set3 set4))) (context-spec-music - (context-spec-music - (make-sequential-music basic) 'Timing) 'Score))) + (context-spec-music (make-sequential-music basic) 'Timing) 'Score))) (define-public (make-mark-set label) - "make the music for the \\mark command." - - (let* - ((set (if (integer? label) - (context-spec-music (make-property-set 'rehearsalMark label) - 'Score) - #f)) - (ev (make-music-by-name 'MarkEvent)) - (ch (make-event-chord (list ev))) - ) - - + "make the music for the \\mark command." + (let* ((set (if (integer? label) + (context-spec-music (make-property-set 'rehearsalMark label) + 'Score) + #f)) + (ev (make-music-by-name 'MarkEvent)) + (ch (make-event-chord (list ev)))) (if set (make-sequential-music (list set ch)) (begin - (ly:music-set-property! ev 'label label) + (set! (ly:music-property ev 'label) label) ch)))) - - (define-public (set-time-signature num den . rest) (ly:export (apply make-time-signature-set `(,num ,den . ,rest)))) (define-public (make-penalty-music pen) - (let - ((m (make-music-by-name 'BreakEvent))) - (ly:music-set-property! m 'penalty pen) + (let ((m (make-music-by-name 'BreakEvent))) + (set! (ly:music-property m 'penalty) pen) m)) (define-public (make-articulation name) - (let* ( - (m (make-music-by-name 'ArticulationEvent)) - ) - (ly:music-set-property! m 'articulation-type name) - m - )) + (let ((m (make-music-by-name 'ArticulationEvent))) + (set! (ly:music-property m 'articulation-type) name) + m)) (define-public (make-lyric-event string duration) - (let* ((m (make-music-by-name 'LyricEvent))) - - (ly:music-set-property! m 'duration duration) - (ly:music-set-property! m 'text string) + (let ((m (make-music-by-name 'LyricEvent))) + (set! (ly:music-property m 'duration) duration) + (set! (ly:music-property m 'text) string) m)) (define-public (make-span-event type spandir) - (let* ( - (m (make-music-by-name type)) - ) - (ly:music-set-property! m 'span-direction spandir) - m - )) + (let ((m (make-music-by-name type))) + (set! (ly:music-property m 'span-direction) spandir) + m)) (define-public (set-mus-properties! m alist) "Set all of ALIST as properties of M." (if (pair? alist) (begin - (ly:music-set-property! m (caar alist) (cdar alist)) - (set-mus-properties! m (cdr alist))) - )) - - + (set! (ly:music-property m (caar alist)) (cdar alist)) + (set-mus-properties! m (cdr alist))))) (define-public (music-separator? m) "Is M a separator?" - (let* ((ts (ly:music-property m 'types ))) - (memq 'separator ts) - )) + (let ((ts (ly:music-property m 'types))) + (memq 'separator ts))) ;;; splitting chords into voices. @@ -510,67 +391,52 @@ Rest can contain a list of beat groupings NUMBER is 0-base, i.e. Voice=1 (upstems) has number 0. " - - (if (null? lst) '() + (if (null? lst) + '() (cons (context-spec-music (make-sequential-music - (list - (make-voice-props-set number) - (make-simultaneous-music (car lst)))) - + (list (make-voice-props-set number) + (make-simultaneous-music (car lst)))) 'Voice (number->string (1+ number))) - (voicify-list (cdr lst) (1+ number)) - )) - ) + (voicify-list (cdr lst) (1+ number))))) (define (voicify-chord ch) "Split the parts of a chord into different Voices using separator" - (let* ((es (ly:music-property ch 'elements))) - - (ly:music-set-property! ch 'elements - (voicify-list (split-list es music-separator?) 0)) - ch - )) + (let ((es (ly:music-property ch 'elements))) + (set! (ly:music-property ch 'elements) + (voicify-list (split-list es music-separator?) 0)) + ch)) (define-public (voicify-music m) - "Recursively split chords that are separated with \\ " - - (if (not (ly:music? m)) - (begin (display m) - (error "not music!")) - ) - (let* - ((es (ly:music-property m 'elements)) - (e (ly:music-property m 'element)) - ) - (if (pair? es) - (ly:music-set-property! m 'elements (map voicify-music es))) - (if (ly:music? e) - (ly:music-set-property! m 'element (voicify-music e))) - (if - (and (equal? (ly:music-name m) "Simultaneous_music") - (reduce (lambda (x y ) (or x y)) #f (map music-separator? es))) - (set! m (context-spec-music (voicify-chord m) 'Staff)) - ) - - m - )) + "Recursively split chords that are separated with \\ " + (if (not (ly:music? m)) + (begin (display m) + (error "not music!"))) + (let ((es (ly:music-property m 'elements)) + (e (ly:music-property m 'element))) + (if (pair? es) + (set! (ly:music-property m 'elements) (map voicify-music es))) + (if (ly:music? e) + (set! (ly:music-property m 'element) (voicify-music e))) + (if (and (equal? (ly:music-name m) "Simultaneous_music") + (reduce (lambda (x y ) (or x y)) #f (map music-separator? es))) + (set! m (context-spec-music (voicify-chord m) 'Staff))) + m)) (define-public (empty-music) - (ly:export (make-music-by-name 'Music)) - ) + (ly:export (make-music-by-name 'Music))) ;;; ; Make a function that checks score element for being of a specific type. (define-public (make-type-checker symbol) (lambda (elt) - ;;(display symbol) + ;;(display symbol) ;;(eq? #t (ly:grob-property elt symbol)) (not (eq? #f (memq symbol (ly:grob-property elt 'interfaces)))))) (define-public ((outputproperty-compatibility func sym val) grob g-context ao-context) (if (func grob) - (ly:grob-set-property! grob sym val))) + (set! (ly:grob-property grob sym) val))) (define-public ((set-output-property grob-name symbol val) grob grob-c context) @@ -579,81 +445,57 @@ Rest can contain a list of beat groupings \\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1)) " - - (let* - ((meta (ly:grob-property grob 'meta))) - + (let ((meta (ly:grob-property grob 'meta))) (if (equal? (cdr (assoc 'name meta)) grob-name) - (ly:grob-set-property! grob symbol val) - ))) + (set! (ly:grob-property grob symbol) val)))) ;; (define-public (smart-bar-check n) - "Make a bar check that checks for a specific bar number. + "Make a bar check that checks for a specific bar number. " - (let* - ( - (m (make-music-by-name 'ApplyContext)) - ) - + (let ((m (make-music-by-name 'ApplyContext))) (define (checker tr) (let* ((bn (ly:context-property tr 'currentBarNumber))) - (if (= bn n) + (if (= bn n) #t (error (format "Bar check failed, we should have reached ~a, instead at ~a\n" - n bn )) - ))) - - (ly:music-set-property! m 'procedure checker) - m - )) + n bn))))) + (set! (ly:music-property m 'procedure) checker) + m)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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-name x) - "Request_chord")) elts) - )) + (reduce (lambda (x y) (or x y)) #f + (map (lambda (x) + (equal? (ly:music-name x) "Request_chord")) + elts))) (define (ly:music-message music msg) - (let* - ( - (ip (ly:music-property music 'origin)) - ) - + (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) (ly:input-message ip msg) - (ly:warn msg)) - )) + (ly:warn 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)) + "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-name music)) - ) - - (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.\nPlease insert an explicit \\context before chord") - (map check-start-chords es))) - - ((equal? name "Sequential_music") + (name (ly:music-name music))) + (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.\nPlease insert an explicit \\context before chord") + (map check-start-chords es))) + ((equal? name "Sequential_music") (if (pair? es) (check-start-chords (car es)))) - (else (if (ly:music? e) (check-start-chords e ))) - - )) - music - ) + (else (if (ly:music? e) (check-start-chords e))))) + music) @@ -666,69 +508,52 @@ Rest can contain a list of beat groupings "Make a new vector consisting of V, with X added to the end." (let* ((n (vector-length v)) - (nv (make-vector (+ n 1) '()))) - - + gm(nv (make-vector (+ n 1) '()))) (vector-move-left! v 0 n nv 0) (vector-set! nv n x) nv)) - (define (vector-map f v) - "Map F over V. This function returns nothing." - (do - ((n (vector-length v)) + "Map F over V. This function returns nothing." + (do ((n (vector-length v)) (i 0 (+ i 1))) ((>= i n)) - (f (vector-ref v i)))) (define (vector-reverse-map f v) - "Map F over V, N to 0 order. This function returns nothing." - (do - ((i (- (vector-length v) 1) (- i 1))) + "Map F over V, N to 0 order. This function returns nothing." + (do ((i (- (vector-length v) 1) (- i 1))) ((< i 0)) - (f (vector-ref v i)))) ;; TODO: make a remove-grace-property too. (define-public (add-grace-property context-name grob sym val) "Set SYM=VAL for GROB in CONTEXT-NAME. " (define (set-prop context) - (let* - ((where (ly:context-property-where-defined context 'graceSettings)) - (current (ly:context-property where 'graceSettings)) - (new-settings (vector-extend current (list context-name grob sym val))) - ) + (let* ((where (ly:context-property-where-defined context 'graceSettings)) + (current (ly:context-property where 'graceSettings)) + (new-settings (vector-extend current (list context-name grob sym val)))) (ly:context-set-property! where 'graceSettings new-settings))) - - (ly:export (context-spec-music (make-apply-context set-prop) 'Voice))) + (ly:export (context-spec-music (make-apply-context set-prop) 'Voice))) (define-public (set-start-grace-properties context) (define (execute-1 x) - (let* - ((tr (ly:translator-find context (car x)))) - + (let ((tr (ly:translator-find context (car x)))) (if (ly:context? tr) - (ly:context-pushpop-property tr (cadr x) (caddr x) (cadddr x)) - ))) + (ly:context-pushpop-property tr (cadr x) (caddr x) (cadddr x))))) - (let* - ((props (ly:context-property context 'graceSettings))) + (let ((props (ly:context-property context 'graceSettings))) (if (vector? props) (vector-map execute-1 props)))) (define-public (set-stop-grace-properties context) (define (execute-1 x) - (let* - ((tr (ly:translator-find context (car x)))) + (let ((tr (ly:translator-find context (car x)))) (if (ly:context? tr) - (ly:context-pushpop-property tr (cadr x) (caddr x)) - ))) + (ly:context-pushpop-property tr (cadr x) (caddr x))))) - (let* - ((props (ly:context-property context 'graceSettings))) + (let ((props (ly:context-property context 'graceSettings))) (if (vector? props) (vector-reverse-map execute-1 props)))) @@ -743,14 +568,11 @@ Rest can contain a list of beat groupings (define-public toplevel-music-functions (list -;; check-start-chords ; ; no longer needed with chord syntax. - voicify-music - (lambda (x) (music-map glue-mm-rest-texts x)) -; switch-on-debugging - )) - - - + ;; check-start-chords ; ; no longer needed with chord syntax. + voicify-music + (lambda (x) (music-map glue-mm-rest-texts x)) + ;; switch-on-debugging + )) ;;;;;;;;;;;;;;;;; ;; lyrics @@ -760,141 +582,122 @@ Rest can contain a list of beat groupings (if (and (not (equal? (ly:music-length music) ZERO-MOMENT)) (ly:duration? (ly:music-property music 'duration))) (begin - (ly:music-set-property! music 'duration (car durations)) - (set! durations (cdr durations)) - ))) - + (set! (ly:music-property music 'duration) (car durations)) + (set! durations (cdr durations))))) + (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)) - (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant")) - (cb (ly:grob-property grob 'print-function))) - - (if (equal? nm object-name) - (begin - (ly:grob-set-property! grob 'print-function Balloon_interface::print) - (ly:grob-set-property! grob 'balloon-original-callback cb) - (ly:grob-set-property! grob 'balloon-text text) - (ly:grob-set-property! grob 'balloon-text-offset off) - (ly:grob-set-property! grob 'balloon-text-props '((font-family . roman))) - - )))) - - + (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) + (begin + (set! (ly:grob-property grob 'print-function) Balloon_interface::print) + (set! (ly:grob-property grob 'balloon-original-callback) 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 -(define-public (set-accidentals-properties - extra-natural - auto-accs auto-cauts - context) +(define-public (set-accidentals-properties extra-natural + auto-accs auto-cauts + context) (context-spec-music (make-sequential-music - (append - (if (boolean? extra-natural) (list (make-property-set 'extraNatural extra-natural)) '()) - (list - (make-property-set 'autoAccidentals auto-accs) - (make-property-set 'autoCautionaries auto-cauts) - ))) + (append (if (boolean? extra-natural) + (list (make-property-set 'extraNatural extra-natural)) + '()) + (list (make-property-set 'autoAccidentals auto-accs) + (make-property-set 'autoCautionaries auto-cauts)))) context)) (define-public (set-accidental-style style . rest) "Set accidental style to STYLE. Optionally takes a context argument, eg. 'Staff or 'Voice. The context defaults to Voice, except for piano styles, which use PianoStaff as a context. " + (let ((context (if (pair? rest) + (car rest) 'Staff)) + (pcontext (if (pair? rest) + (car rest) 'PianoStaff))) + (ly:export + (cond + ;; accidentals as they were common in the 18th century. + ((equal? style 'default) + (set-accidentals-properties #t '(Staff (same-octave . 0)) + '() context)) + ;; accidentals from one voice do NOT get cancelled in other voices + ((equal? style 'voice) + (set-accidentals-properties #t '(Voice (same-octave . 0)) + '() context)) + ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century. + ;; This includes all the default accidentals, but accidentals also needs cancelling + ;; in other octaves and in the next measure. + ((equal? style 'modern) + (set-accidentals-properties #f '(Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) + '() context)) + ;; the accidentals that Stone adds to the old standard as cautionaries + ((equal? style 'modern-cautionary) + (set-accidentals-properties #f '(Staff (same-octave . 0)) + '(Staff (any-octave . 0) (same-octave . 1)) + context)) + ;; Multivoice accidentals to be read both by musicians playing one voice + ;; and musicians playing all voices. + ;; Accidentals are typeset for each voice, but they ARE cancelled across voices. + ((equal? style 'modern-voice) + (set-accidentals-properties #f + '(Voice (same-octave . 0) (any-octave . 0) (same-octave . 1) + Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) + '() + context)) + ;; same as modernVoiceAccidental eccept that all special accidentals are typeset + ;; as cautionaries + ((equal? style 'modern-voice-cautionary) + (set-accidentals-properties #f + '(Voice (same-octave . 0) ) + '(Voice (any-octave . 0) (same-octave . 1) + Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) + context)) + ;; stone's suggestions for accidentals on grand staff. + ;; Accidentals are cancelled across the staves in the same grand staff as well + ((equal? style 'piano) + (set-accidentals-properties #f + '( Staff (same-octave . 0) (any-octave . 0) (same-octave . 1) + PianoStaff (any-octave . 0) (same-octave . 1)) + '() + pcontext)) + ((equal? style 'piano-cautionary) + (set-accidentals-properties #f + '(Staff (same-octave . 0)) + '(Staff (any-octave . 0) (same-octave . 1) + PianoStaff (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 + ((equal? style 'forget) + (set-accidentals-properties '() + '(Staff (same-octave . -1)) + '() context)) + ;; Do not reset the key at the start of a measure. Accidentals will be + ;; printed only once and are in effect until overridden, possibly many + ;; measures later. + ((equal? style 'no-reset) + (set-accidentals-properties '() + '(Staff (same-octave . #t)) + '() + context)) + (else + (ly:warn (string-append "Unknown accidental style: " (symbol->string style))) + (make-sequential-music '())))))) - (let - ((context (if (pair? rest) - (car rest) 'Staff)) - (pcontext (if (pair? rest) - (car rest) 'PianoStaff)) - ) - - (ly:export - - (cond - ; accidentals as they were common in the 18th century. - ((equal? style 'default) (set-accidentals-properties #t '(Staff (same-octave . 0)) '() context)) - - ; accidentals from one voice do NOT get cancelled in other voices - ((equal? style 'voice) (set-accidentals-properties #t '(Voice (same-octave . 0)) '() context)) - - ; accidentals as suggested by Kurt Stone, Music Notation in the 20th century. - ; This includes all the default accidentals, but accidentals also needs cancelling - ; in other octaves and in the next measure. - ((equal? style 'modern) (set-accidentals-properties #f '(Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) '() context)) - - ; the accidentals that Stone adds to the old standard as cautionaries - ((equal? style 'modern-cautionary) - (set-accidentals-properties #f '(Staff (same-octave . 0)) - '(Staff (any-octave . 0) (same-octave . 1)) - context)) - - ; Multivoice accidentals to be read both by musicians playing one voice - ; and musicians playing all voices. - ; Accidentals are typeset for each voice, but they ARE cancelled across voices. - ((equal? style 'modern-voice) - (set-accidentals-properties #f - '(Voice (same-octave . 0) (any-octave . 0) (same-octave . 1) - Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) - '() - context)) - - ; same as modernVoiceAccidental eccept that all special accidentals are typeset - ; as cautionaries - - ((equal? style 'modern-voice-cautionary) - (set-accidentals-properties #f - '(Voice (same-octave . 0) ) - '(Voice (any-octave . 0) (same-octave . 1) - Staff (same-octave . 0) (any-octave . 0) (same-octave . 1)) - context)) - - ; stone's suggestions for accidentals on grand staff. - ; Accidentals are cancelled across the staves in the same grand staff as well - ((equal? style 'piano) - (set-accidentals-properties #f - '( Staff (same-octave . 0) (any-octave . 0) (same-octave . 1) - PianoStaff (any-octave . 0) (same-octave . 1)) - '() - pcontext)) - ((equal? style 'piano-cautionary) - (set-accidentals-properties #f - '(Staff (same-octave . 0)) - '(Staff (any-octave . 0) (same-octave . 1) - PianoStaff (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 - ((equal? style 'forget) - (set-accidentals-properties '() - '(Staff (same-octave . -1)) - '() context)) - - ; Do not reset the key at the start of a measure. Accidentals will be - ; printed only once and are in effect until overridden, possibly many - ; measures later. - ((equal? style 'no-reset) - (set-accidentals-properties '() - '(Staff (same-octave . #t)) - '() - context)) - (else - (ly:warn (string-append "Unknown accidental style: " (symbol->string style))) - (make-sequential-music '()) - )) - ))) diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm index a4c21b7767..0ba7529d01 100644 --- a/scm/part-combiner.scm +++ b/scm/part-combiner.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Han-Wen Nienhuys +;;;; (c) 2004 Han-Wen Nienhuys ;; todo: figure out how to make module, ;; without breaking nested ly scopes @@ -14,12 +14,10 @@ (split-index #:accessor split-index) (vector-index) (state-vector) - - ;;; - ; spanner-state is an alist - ; of (SYMBOL . RESULT-INDEX), which indicates where - ; said spanner was started. + ;; spanner-state is an alist + ;; of (SYMBOL . RESULT-INDEX), which indicates where + ;; said spanner was started. (spanner-state #:init-value '() #:accessor span-state) ) (define-method (write (x ) file) @@ -32,28 +30,25 @@ (define-method (note-events (vs )) (define (f? x) - (equal? (ly:music-property x 'name) 'NoteEvent)) + (equal? (ly:music-property x 'name) 'NoteEvent)) (filter f? (events vs))) (define-method (previous-voice-state (vs )) - (let* ((i (slot-ref vs 'vector-index)) - (v (slot-ref vs 'state-vector)) ) + (let ((i (slot-ref vs 'vector-index)) + (v (slot-ref vs 'state-vector)) ) (if (< 0 i) (vector-ref v (1- i)) - #f) - )) - + #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () (configuration #:init-value '() #:accessor configuration) (when-moment #:accessor when #:init-keyword #:when) - - ; voice-states are states starting with the Split-state or later - ; + ;; voice-states are states starting with the Split-state or later + ;; (is #:init-keyword #:voice-states #:accessor voice-states) - (synced #:init-keyword #:synced #:init-value #f #:getter synced?) ) + (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) (define-method (write (x ) f) @@ -68,75 +63,52 @@ (define (previous-span-state vs) - (let* - ((p (previous-voice-state vs))) - - (if p (span-state p) - '()) - )) + (let ((p (previous-voice-state vs))) + (if p (span-state p) '()))) (define (make-voice-states evl) - (let - ((vec - (list->vector - (map - (lambda (v) - (make - #:when (caar v) - #:tuning (cdar v) - #:events (map car (cdr v)) - )) - evl)))) - + (let ((vec (list->vector (map (lambda (v) + (make + #:when (caar v) + #:tuning (cdar v) + #:events (map car (cdr v)))) + evl)))) (do ( (i 0 (1+ i)) ) ( (= i (vector-length vec)) vec) (slot-set! (vector-ref vec i) 'vector-index i) - (slot-set! (vector-ref vec i) 'state-vector vec) - ))) - + (slot-set! (vector-ref vec i) 'state-vector vec)))) (define (make-split-state vs1 vs2) "Merge lists VS1 and VS2, containing Voice-state objects into vector of Split-state objects, crosslinking the Split-state vector and Voice-state objects -" - +" (define (helper ss-idx ss-list idx1 idx2) - (let* - ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) - (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) - (min (cond ((and s1 s2) (moment-min (when s1) (when s2))) - (s1 (when s1)) - (s2 (when s2)) - (else #f) - )) - - (inc1 (if (and s1 (equal? min (when s1))) 1 0)) - (inc2 (if (and s2 (equal? min (when s2))) 1 0)) - (ss-object - (if min - (make - #:when min - #:voice-states (cons s1 s2) - #:synced (= inc1 inc2) - ) #f)) ) + (let* ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) + (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) + (min (cond ((and s1 s2) (moment-min (when s1) (when s2))) + (s1 (when s1)) + (s2 (when s2)) + (else #f))) + (inc1 (if (and s1 (equal? min (when s1))) 1 0)) + (inc2 (if (and s2 (equal? min (when s2))) 1 0)) + (ss-object (if min + (make + #:when min + #:voice-states (cons s1 s2) + #:synced (= inc1 inc2)) + #f))) (if s1 (set! (split-index s1) ss-idx)) (if s2 (set! (split-index s2) ss-idx)) - (if min (helper (1+ ss-idx) (cons ss-object ss-list) (+ idx1 inc1) (+ idx2 inc2)) - ss-list ) - )) - - (list->vector - (reverse! - (helper 0 '() 0 0) '())) ) - + ss-list))) + (list->vector (reverse! (helper 0 '() 0 0) '()))) (define (analyse-spanner-states voice-state-vec) @@ -147,82 +119,57 @@ Voice-state objects (define (analyse-tie-start active ev) (if (equal? (ly:music-property ev 'name) 'TieEvent) (acons 'tie index active) - active - )) + active)) (define (analyse-tie-end active ev) (if (equal? (ly:music-property ev 'name) 'NoteEvent) (assoc-remove! active 'tie) - active) ) + active)) (define (analyse-absdyn-end active ev) (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent) - (assoc-remove! - (assoc-remove! active 'cresc) - 'decr) - active) ) + (assoc-remove! (assoc-remove! active 'cresc) 'decr) + active)) (define (active (length notes1) 1) (put 'apart)) + ((> (length notes2) 1) (put 'apart)) + ((not (= (length notes1) (length notes2))) + (put 'apart)) + ((and (= (length durs1) 1) + (= (length durs2) 1) + (not (equal? (car durs1) (car durs2)))) + (put 'apart)) + (else + (if (and (= (length pitches1) (length pitches2))) + (if (and (pair? pitches1) + (pair? pitches2) + (< chord-threshold (ly:pitch-steps + (ly:pitch-diff (car pitches1) (car pitches2))))) + (put 'apart) + ;; copy previous split state from spanner state + (begin + (if (previous-voice-state vs1) + (copy-state-from voice-state-vec1 + (previous-voice-state vs1))) + (if (previous-voice-state vs2) + (copy-state-from voice-state-vec2 + (previous-voice-state vs2))) + (if (and (null? (span-state vs1)) (null? (span-state vs2))) + (put 'chords))))))))) - (map copy-one-state (span-state vs)) ) - - (define (analyse-notes now-state) - (let* - ( - (vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state))) - - (notes1 (note-events vs1)) - (durs1 (sort (map (lambda (x) (ly:music-property x 'duration)) notes1) ly:duration (length notes1) 1) (put 'apart)) - ((> (length notes2) 1) (put 'apart)) - ((not (= (length notes1) (length notes2))) - (put 'apart)) - ((and - (= (length durs1) 1) - (= (length durs2) 1) - (not (equal? (car durs1) (car durs2)))) - - (put 'apart)) - (else - (if (and (= (length pitches1) (length pitches2))) - (if (and (pair? pitches1) - (pair? pitches2) - (< chord-threshold (ly:pitch-steps - (ly:pitch-diff (car pitches1) (car pitches2))))) - (put 'apart) - - ;; copy previous split state from spanner state - (begin - (if (previous-voice-state vs1) - (copy-state-from voice-state-vec1 - (previous-voice-state vs1))) - (if (previous-voice-state vs2) - (copy-state-from voice-state-vec2 - (previous-voice-state vs2))) - (if (and (null? (span-state vs1)) (null? (span-state vs2))) - (put 'chords)) - - )))) - ))) - - - - (if (< ri (vector-length result)) - (let* - ((now-state (vector-ref result ri)) - (vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state)))) - - (cond - ((not vs1) (put 'apart)) - ((not vs2) (put 'apart)) - (else - (let* - ( - (active1 (previous-span-state vs1)) - (active2 (previous-span-state vs2)) - - (new-active1 (span-state vs1)) - (new-active2 (span-state vs2)) ) - (if - pc-debug - (display (list (when now-state) ri - active1 "->" new-active1 - active2 "->" new-active2 - "\n"))) - - - - (if (and (synced? now-state) - (equal? active1 active2) - (equal? new-active1 new-active2)) - - (analyse-notes now-state) - - ;; active states different: - (put 'apart) - )) - - ; go to the next one, if it exists. - (analyse-time-step (1+ ri)) - ))))) + (if (< ri (vector-length result)) + (let* ((now-state (vector-ref result ri)) + (vs1 (car (voice-states now-state))) + (vs2 (cdr (voice-states now-state)))) + (cond ((not vs1) (put 'apart)) + ((not vs2) (put 'apart)) + (else + (let ((active1 (previous-span-state vs1)) + (active2 (previous-span-state vs2)) + (new-active1 (span-state vs1)) + (new-active2 (span-state vs2))) + (if pc-debug + (display (list (when now-state) ri + active1 "->" new-active1 + active2 "->" new-active2 + "\n"))) + (if (and (synced? now-state) + (equal? active1 active2) + (equal? new-active1 new-active2)) + (analyse-notes now-state) + ;; active states different: + (put 'apart))) + ;; go to the next one, if it exists. + (analyse-time-step (1+ ri))))))) - (define (analyse-a2 ri) - (if (< ri (vector-length result)) - (let* - ((now-state (vector-ref result ri)) - (vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state))) ) - - (if (and (equal? (configuration now-state) 'chords) - vs1 vs2) - - (let* - ((notes1 (note-events vs1)) - (notes2 (note-events vs2)) ) - (cond - ((and - (= 1 (length notes1)) - (= 1 (length notes2)) - (equal? (ly:music-property (car notes1) 'pitch) - (ly:music-property (car notes2) 'pitch))) - - (set! (configuration now-state) 'unisono)) - ((and - (= 0 (length notes1)) - (= 0 (length notes2))) - (set! (configuration now-state) 'unisilence))) - - )) - (analyse-a2 (1+ ri)) - - ))) - - (define (analyse-solo12 ri) + (define (analyse-a2 ri) + (if (< ri (vector-length result)) + (let* ((now-state (vector-ref result ri)) + (vs1 (car (voice-states now-state))) + (vs2 (cdr (voice-states now-state)))) + (if (and (equal? (configuration now-state) 'chords) + vs1 vs2) + (let ((notes1 (note-events vs1)) + (notes2 (note-events vs2))) + (cond ((and (= 1 (length notes1)) + (= 1 (length notes2)) + (equal? (ly:music-property (car notes1) 'pitch) + (ly:music-property (car notes2) 'pitch))) + (set! (configuration now-state) 'unisono)) + ((and (= 0 (length notes1)) + (= 0 (length notes2))) + (set! (configuration now-state) 'unisilence))))) + (analyse-a2 (1+ ri))))) - (define (previous-config vs) - (let* ((pvs (previous-voice-state vs)) + (define (analyse-solo12 ri) + + (define (previous-config vs) + (let* ((pvs (previous-voice-state vs)) (spi (if pvs (split-index pvs) #f)) - (prev-split (if spi (vector-ref result spi) #f)) ) - - (if prev-split - (configuration prev-split) - 'apart) - - )) - (define (put-range x a b) -; (display (list "put range " x a b "\n")) - (do - ((i a (1+ i))) - ((> i b) b) - (set! (configuration (vector-ref result i)) x) - )) - - (define (put x) -; (display (list "putting " x "\n")) - - (set! (configuration (vector-ref result ri)) x)) - - (define (current-voice-state now-state voice-num) - (define vs ((if (= 1 voice-num) car cdr) - (voice-states now-state) ) ) - (if (or (not vs) (equal? (when now-state) (when vs))) - vs - (previous-voice-state vs) - )) - - (define (try-solo type start-idx current-idx) - "Find a maximum stretch that can be marked as solo. Only set + (prev-split (if spi (vector-ref result spi) #f))) + (if prev-split + (configuration prev-split) + 'apart))) + + (define (put-range x a b) + ;; (display (list "put range " x a b "\n")) + (do ((i a (1+ i))) + ((> i b) b) + (set! (configuration (vector-ref result i)) x))) + + (define (put x) + ;; (display (list "putting " x "\n")) + (set! (configuration (vector-ref result ri)) x)) + + (define (current-voice-state now-state voice-num) + (define vs ((if (= 1 voice-num) car cdr) + (voice-states now-state))) + (if (or (not vs) (equal? (when now-state) (when vs))) + vs + (previous-voice-state vs))) + + (define (try-solo type start-idx current-idx) + "Find a maximum stretch that can be marked as solo. Only set the mark when there are no spanners active." - (if (< current-idx (vector-length result)) - (let* - ((now-state (vector-ref result current-idx)) - (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) - - (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) - (silent-notes (if silent-state (note-events silent-state) '())) - (solo-notes (if solo-state (note-events solo-state) '())) - - (soln (length solo-notes)) - (siln (length silent-notes))) - -; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n")) - (cond - ((not (equal? (configuration now-state) 'apart)) - current-idx) - ((> siln 0) start-idx) - - ((and - ; - ; This includes rests. This isn't a problem: long rests - ; will be shared with the silent voice, and be marked - ; as unisilence. Therefore, long rests won't - ; accidentally be part of a solo. - ; - (null? (span-state solo-state))) - (put-range type start-idx current-idx) - (try-solo type (1+ current-idx) (1+ current-idx))) - (else - (try-solo type start-idx (1+ current-idx))) - - )) - start-idx)) ; try-solo - - - (define (analyse-moment ri) - "Analyse 'apart starting at RI. Return next index. " - (let* - ((now-state (vector-ref result ri)) - (vs1 (current-voice-state now-state 1)) - (vs2 (current-voice-state now-state 2)) -; (vs1 (car (voice-states now-state))) -; (vs2 (cdr (voice-states now-state))) - (notes1 (if vs1 (note-events vs1) '())) - (notes2 (if vs2 (note-events vs2) '())) - (n1 (length notes1)) - (n2 (length notes2)) ) - -; (display (list "analyzing step " ri " moment " (when now-state) vs1 vs2 "\n")) - - + (if (< current-idx (vector-length result)) + (let* ((now-state (vector-ref result current-idx)) + (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) + (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) + (silent-notes (if silent-state (note-events silent-state) '())) + (solo-notes (if solo-state (note-events solo-state) '())) + (soln (length solo-notes)) + (siln (length silent-notes))) + ;; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n")) + (cond ((not (equal? (configuration now-state) 'apart)) + current-idx) + ((> siln 0) start-idx) + ((and (null? (span-state solo-state))) + ;; + ;; This includes rests. This isn't a problem: long rests + ;; will be shared with the silent voice, and be marked + ;; as unisilence. Therefore, long rests won't + ;; accidentally be part of a solo. + ;; + (put-range type start-idx current-idx) + (try-solo type (1+ current-idx) (1+ current-idx))) + (else + (try-solo type start-idx (1+ current-idx))))) + start-idx)) ; try-solo + + (define (analyse-moment ri) + "Analyse 'apart starting at RI. Return next index. " + (let* ((now-state (vector-ref result ri)) + (vs1 (current-voice-state now-state 1)) + (vs2 (current-voice-state now-state 2)) + ;; (vs1 (car (voice-states now-state))) + ;; (vs2 (cdr (voice-states now-state))) + (notes1 (if vs1 (note-events vs1) '())) + (notes2 (if vs2 (note-events vs2) '())) + (n1 (length notes1)) + (n2 (length notes2))) + ;; (display (list "analyzing step " ri " moment " (when now-state) vs1 vs2 "\n")) (max ; we should always increase. - (cond - ((and (= n1 0) (= n2 0)) - (put 'apart-silence) - (1+ ri) ) - - ((and (= n2 0) - (equal? (when vs1) (when now-state)) - (null? (previous-span-state vs1))) - (try-solo 'solo1 ri ri)) - ((and (= n1 0) - (equal? (when vs2) (when now-state)) - (null? (previous-span-state vs2))) - (try-solo 'solo2 ri ri)) - (else (1+ ri) )) - (1+ ri)) - )) ; analyse-moment - - (if (< ri (vector-length result)) - (if (equal? (configuration (vector-ref result ri)) 'apart) - (analyse-solo12 (analyse-moment ri)) - (analyse-solo12 (1+ ri)))) ) ; analyse-solo12 - - - (analyse-spanner-states voice-state-vec1) - (analyse-spanner-states voice-state-vec2) - - (if #f - (begin - (display voice-state-vec1) - (display "***\n") - (display voice-state-vec2) - (display "***\n") - (display result) - (display "***\n") - )) - - (analyse-time-step 0) -; (display result) - (analyse-a2 0) -; (display result) - (analyse-solo12 0) -; (display result) - - (set! result (map - (lambda (x) (cons (when x) (configuration x))) - (vector->list result))) - -; (if pc-debug (display result)) - result)) - + (cond ((and (= n1 0) (= n2 0)) + (put 'apart-silence) + (1+ ri)) + ((and (= n2 0) + (equal? (when vs1) (when now-state)) + (null? (previous-span-state vs1))) + (try-solo 'solo1 ri ri)) + ((and (= n1 0) + (equal? (when vs2) (when now-state)) + (null? (previous-span-state vs2))) + (try-solo 'solo2 ri ri)) + (else (1+ ri))) + (1+ ri)))) ; analyse-moment + + (if (< ri (vector-length result)) + (if (equal? (configuration (vector-ref result ri)) 'apart) + (analyse-solo12 (analyse-moment ri)) + (analyse-solo12 (1+ ri))))) ; analyse-solo12 + + (analyse-spanner-states voice-state-vec1) + (analyse-spanner-states voice-state-vec2) + (if #f + (begin + (display voice-state-vec1) + (display "***\n") + (display voice-state-vec2) + (display "***\n") + (display result) + (display "***\n"))) + (analyse-time-step 0) + ;; (display result) + (analyse-a2 0) + ;; (display result) + (analyse-solo12 0) + ;; (display result) + (set! result (map + (lambda (x) (cons (when x) (configuration x))) + (vector->list result))) + ;; (if pc-debug (display result)) + result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; autochange - fairly related to part combining. (define-public (make-autochange-music music) - (define (generate-split-list event-list acc) (if (null? event-list) acc - (let* - ((now-tun (caar event-list)) - (evs (map car (cdar event-list))) - (now (car now-tun)) - (notes (filter (lambda (x) - (equal? (ly:music-property x 'name) 'NoteEvent)) + (let* ((now-tun (caar event-list)) + (evs (map car (cdar event-list))) + (now (car now-tun)) + (notes (filter (lambda (x) + (equal? (ly:music-property x 'name) 'NoteEvent)) evs)) - (pitch (if (pair? notes) - (ly:music-property (car notes) 'pitch) - #f)) ) - - ;; tail recursive. - (if (and pitch (not (= (ly:pitch-steps pitch) 0))) - (generate-split-list - (cdr event-list) - (cons (cons now (sign (ly:pitch-steps pitch))) acc)) - (generate-split-list (cdr event-list) acc) - )) - )) - + (pitch (if (pair? notes) + (ly:music-property (car notes) 'pitch) + #f))) + ;; tail recursive. + (if (and pitch (not (= (ly:pitch-steps pitch) 0))) + (generate-split-list (cdr event-list) + (cons (cons now (sign (ly:pitch-steps pitch))) acc)) + (generate-split-list (cdr event-list) acc))))) (set! noticed '()) - - (let* - ((m (make-music-by-name 'AutoChangeMusic)) - (context (ly:run-translator music part-combine-listener)) - (evs (last-pair noticed)) - (split - (reverse! - (generate-split-list (if (pair? evs) - (reverse! (cdar evs) '()) '()) - '()) - '()) - )) - - (ly:music-set-property! m 'element music) - (ly:music-set-property! m 'split-list split) - + (let* ((m (make-music-by-name 'AutoChangeMusic)) + (context (ly:run-translator music part-combine-listener)) + (evs (last-pair noticed)) + (split (reverse! (generate-split-list (if (pair? evs) + (reverse! (cdar evs) '()) '()) + '()) + '()))) + (set! (ly:music-property m 'element) music) + (set! (ly:music-property m 'split-list) split) (set! noticed '()) - m - )) + m)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (add-quotable name mus) (set! noticed '()) - (let* - ((tab (eval 'musicQuotes (current-module) )) - (context (ly:run-translator (context-spec-music mus 'Voice) - part-combine-listener)) - (evs (last-pair noticed)) - ) - + (let* ((tab (eval 'musicQuotes (current-module) )) + (context (ly:run-translator (context-spec-music mus 'Voice) + part-combine-listener)) + (evs (last-pair noticed))) (if (pair? evs) (hash-set! tab name - (list->vector (reverse! (car evs) '())))) - )) + (list->vector (reverse! (car evs) '())))))) -- 2.39.2