Hi,
I finished the scheme part of the part-combiner. Attached is the patch.
There are still bugs in the C part which I cannot solve:
- When there are two voices unisilence, one of them a multimeasure rest,
and the other a smaller rest, than sometimes the multimeasure rest
swallows the other, with the result that there appears a gap before the
first note.
- Sometimes slur-events are swallowed, so a slur appears to have no end.
- Multimeasure rests are not positioned according to their voice, but
always appear in the middle.
I would solve these problems myself if I could, but it would take to much
time with my limited understanding of lilypond internals.
Kristof Bastiaensen
Changelog:
2005-07-07 Kristof Bastiaensen <[EMAIL PROTECTED]>
* ly/declarations-init.ly: Set the properties to record for the
part-combiner.
* scm/part-combiner.scm: Complete rewrite of the part-combiner.
* lily/moment-scheme.cc: Added the scheme function ly:sub-moment
to subtract moments.
* lily/recording-group-engraver.cc: Added the possibility to
record properties by putting their name in the recordProperties
property.
? Documentation/out
? Documentation/bibliography/out
? Documentation/misc/out
? Documentation/pictures/out
? Documentation/topdocs/out
? Documentation/user/out
? buildscripts/out
? cygwin/out
? debian/out
? elisp/out
? flower/out
? flower/include/out
? input/out
? input/mutopia/out
? input/mutopia/E.Satie/out
? input/mutopia/F.Schubert/out
? input/mutopia/J.S.Bach/out
? input/mutopia/R.Schumann/out
? input/mutopia/W.A.Mozart/out
? input/no-notation/out
? input/regression/out
? input/test/out
? input/tutorial/out
? kpath-guile/out
? lily/out
? lily/include/out
? ly/out
? make/out
? mf/out
? po/out
? ps/out
? python/out
? scm/out
? scripts/out
? stepmake/out
? stepmake/bin/out
? stepmake/stepmake/out
? tex/out
? vim/out
Index: ChangeLog
===================================================================
RCS file: /cvsroot/lilypond/lilypond/ChangeLog,v
retrieving revision 1.3850
diff -u -r1.3850 ChangeLog
--- ChangeLog 1 Jul 2005 12:53:03 -0000 1.3850
+++ ChangeLog 6 Jul 2005 23:52:42 -0000
@@ -1,3 +1,17 @@
+2005-07-07 Kristof Bastiaensen <[EMAIL PROTECTED]>
+
+ * ly/declarations-init.ly: Set the properties to record for the
+ part-combiner.
+
+ * scm/part-combiner.scm: Complete rewrite of the part-combiner.
+
+ * lily/moment-scheme.cc: Added the scheme function ly:sub-moment
+ to subtract moments.
+
+ * lily/recording-group-engraver.cc: Added the possibility to
+ record properties by putting their name in the recordProperties
+ property.
+
2005-07-01 Mats Bengtsson <[EMAIL PROTECTED]>
* Documentation/user/advanced-notation.itely (Setting automatic
Index: lily/moment-scheme.cc
===================================================================
RCS file: /cvsroot/lilypond/lilypond/lily/moment-scheme.cc,v
retrieving revision 1.8
diff -u -r1.8 moment-scheme.cc
--- lily/moment-scheme.cc 21 Apr 2005 14:28:31 -0000 1.8
+++ lily/moment-scheme.cc 6 Jul 2005 23:52:45 -0000
@@ -53,6 +53,17 @@
return (*ma + *mb).smobbed_copy ();
}
+LY_DEFINE (ly_sub_moment, "ly:sub-moment",
+ 2, 0, 0, (SCM a, SCM b),
+ "Subtract two moments.")
+{
+ Moment *ma = unsmob_moment (a);
+ Moment *mb = unsmob_moment (b);
+ SCM_ASSERT_TYPE (ma, a, SCM_ARG1, __FUNCTION__, "moment");
+ SCM_ASSERT_TYPE (mb, b, SCM_ARG2, __FUNCTION__, "moment");
+ return (*ma - *mb).smobbed_copy ();
+}
+
LY_DEFINE (ly_mul_moment, "ly:mul-moment",
2, 0, 0, (SCM a, SCM b),
"Multiply two moments.")
Index: lily/recording-group-engraver.cc
===================================================================
RCS file: /cvsroot/lilypond/lilypond/lily/recording-group-engraver.cc,v
retrieving revision 1.24
diff -u -r1.24 recording-group-engraver.cc
--- lily/recording-group-engraver.cc 10 Mar 2005 14:36:13 -0000 1.24
+++ lily/recording-group-engraver.cc 6 Jul 2005 23:52:45 -0000
@@ -16,12 +16,16 @@
TRANSLATOR_DECLARATIONS (Recording_group_engraver);
virtual bool try_music (Music *m);
void add_music (SCM, SCM);
+ void detect_property_differences();
+ void create_property_lists (SCM);
virtual void stop_translation_timestep ();
virtual void finalize ();
virtual void initialize ();
virtual void derived_mark () const;
SCM now_events_;
SCM accumulator_;
+ SCM property_values_; // a list with the current values for the properties
+ SCM property_alist_; // an alist containing the properties and their values
};
void
@@ -30,6 +34,8 @@
Engraver_group_engraver::derived_mark ();
scm_gc_mark (now_events_);
scm_gc_mark (accumulator_);
+ scm_gc_mark (property_values_);
+ scm_gc_mark (property_alist_);
}
void
@@ -42,6 +48,8 @@
{
accumulator_ = SCM_EOL;
now_events_ = SCM_EOL;
+ property_alist_ = SCM_EOL;
+ property_values_ = SCM_BOOL_F;
}
void
@@ -51,15 +59,67 @@
}
void
+Recording_group_engraver::create_property_lists (SCM properties)
+{
+ property_values_ = SCM_EOL;
+
+ for(; scm_is_pair (properties); properties = scm_cdr(properties))
+ {
+ SCM prop = scm_car (properties);
+ SCM value = internal_get_property(prop);
+
+ property_alist_ = scm_acons (prop, value, property_alist_);
+ property_values_ = scm_cons (value, property_values_);
+ }
+
+ //property_values_ must be in the same order as the properties
+ property_values_ = scm_reverse (property_values_);
+}
+
+void
+Recording_group_engraver::detect_property_differences()
+{
+ SCM property_requests = get_property("recordProperties");
+
+ // add changed properties to property_alist_
+
+ property_alist_ = SCM_EOL;
+ if( scm_is_pair (property_requests) )
+ {
+ if (SCM_BOOL_F == property_values_)
+ create_property_lists (property_requests);
+ else
+ {
+ for(SCM value_list = property_values_;
+ scm_is_pair (property_requests);
+ property_requests = scm_cdr (property_requests),
+ value_list = scm_cdr (value_list))
+ {
+ SCM prop = scm_car (property_requests);
+ SCM new_value = internal_get_property (prop);
+ if (new_value != scm_car (value_list))
+ {
+ scm_set_car_x (value_list, new_value);
+ property_alist_ = scm_acons (prop, new_value, property_alist_);
+ }
+ }
+ }
+ }
+}
+
+void
Recording_group_engraver::stop_translation_timestep ()
{
Engraver_group_engraver::stop_translation_timestep ();
+ detect_property_differences();
accumulator_ = scm_acons (scm_cons (now_mom ().smobbed_copy (),
- get_property ("instrumentTransposition")),
+ property_alist_),
now_events_,
accumulator_);
+
now_events_ = SCM_EOL;
+ property_alist_ = SCM_EOL;
}
void
@@ -70,6 +130,9 @@
if (ly_c_procedure_p (proc))
scm_call_2 (proc, context ()->self_scm (), scm_cdr (accumulator_));
+
+ property_values_ = SCM_BOOL_F;
+ property_alist_ = SCM_EOL;
}
bool
Index: ly/declarations-init.ly
===================================================================
RCS file: /cvsroot/lilypond/lilypond/ly/declarations-init.ly,v
retrieving revision 1.87
diff -u -r1.87 declarations-init.ly
--- ly/declarations-init.ly 28 Jun 2005 11:10:23 -0000 1.87
+++ ly/declarations-init.ly 6 Jul 2005 23:52:46 -0000
@@ -97,6 +97,7 @@
\consists Rest_engraver
\type "Recording_group_engraver"
recordEventSequence = #notice-the-events-for-pc
+ recordProperties = #'(timeSignatureFraction measurePosition)
}
\context {
\Score
Index: scm/part-combiner.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/part-combiner.scm,v
retrieving revision 1.43
diff -u -r1.43 part-combiner.scm
--- scm/part-combiner.scm 28 Mar 2005 19:50:16 -0000 1.43
+++ scm/part-combiner.scm 6 Jul 2005 23:52:47 -0000
@@ -4,185 +4,40 @@
;;;;
;;;; (c) 2004--2005 Han-Wen Nienhuys <[EMAIL PROTECTED]>
-;; todo: figure out how to make module,
-;; without breaking nested ly scopes
+(use-modules (srfi srfi-8))
+(use-modules (srfi srfi-9))
-(define-class <Voice-state> ()
- (event-list #:init-value '() #:accessor events #:init-keyword #:events)
- (when-moment #:accessor when #:init-keyword #:when)
- (tuning #:accessor tuning #:init-keyword #:tuning)
- (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 #:init-value '() #:accessor span-state))
-
-(define-method (write (x <Voice-state> ) file)
- (display (when x) file)
- (display " evs = " file)
- (display (events x) file)
- (display " active = " file)
- (display (span-state x) file)
- (display "\n" file))
-
-(define-method (note-events (vs <Voice-state>))
- (define (f? x)
- (equal? (ly:music-property x 'name) 'NoteEvent))
- (filter f? (events vs)))
-
-(define-method (previous-voice-state (vs <Voice-state>))
- (let ((i (slot-ref vs 'vector-index))
- (v (slot-ref vs 'state-vector)))
- (if (< 0 i)
- (vector-ref v (1- i))
- #f)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-class <Split-state> ()
- (configuration #:init-value '() #:accessor configuration)
- (when-moment #:accessor when #:init-keyword #:when)
- ;; 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?))
-
-
-(define-method (write (x <Split-state> ) f)
- (display (when x) f)
- (display " = " f)
- (display (configuration x) f)
- (if (synced? x)
- (display " synced "))
- (display "\n" f))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(define (previous-span-state vs)
- (let ((p (previous-voice-state vs)))
- (if p (span-state p) '())))
-
-(define (make-voice-states evl)
- (let ((vec (list->vector (map (lambda (v)
- (make <Voice-state>
- #: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))))
-
-(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* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
- (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
- (min (cond ((and state1 state2) (moment-min (when state1) (when state2)))
- (state1 (when state1))
- (state2 (when state2))
- (else #f)))
- (inc1 (if (and state1 (equal? min (when state1))) 1 0))
- (inc2 (if (and state2 (equal? min (when state2))) 1 0))
- (ss-object (if min
- (make <Split-state>
- #:when min
- #:voice-states (cons state1 state2)
- #:synced (= inc1 inc2))
- #f)))
- (if state1
- (set! (split-index state1) ss-idx))
- (if state2
- (set! (split-index state2) 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) '())))
-
-(define (analyse-spanner-states voice-state-vec)
-
- (define (helper index active)
- "Analyse EVS at INDEX, given state ACTIVE."
-
- (define (analyse-tie-start active ev)
- (if (equal? (ly:music-property ev 'name) 'TieEvent)
- (acons 'tie (split-index (vector-ref voice-state-vec index))
- active)
- active))
-
- (define (analyse-tie-end active ev)
- (if (equal? (ly:music-property ev 'name) 'NoteEvent)
- (assoc-remove! active 'tie)
- active))
-
- (define (analyse-absdyn-end active ev)
- (if (or (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
- (and (equal? (ly:music-property ev 'name) 'CrescendoEvent)
- (equal? STOP (ly:music-property ev 'span-direction))))
- (assoc-remove! (assoc-remove! active 'cresc) 'decr)
- active))
-
- (define (active<? a b)
- (cond ((symbol<? (car a) (car b)) #t)
- ((symbol<? (car b) (car b)) #f)
- (else (< (cdr a) (cdr b)))))
-
- (define (analyse-span-event active ev)
- (let* ((name (ly:music-property ev 'name))
- (key (cond ((equal? name 'SlurEvent) 'slur)
- ((equal? name 'PhrasingSlurEvent) 'tie)
- ((equal? name 'BeamEvent) 'beam)
- ((equal? name 'CrescendoEvent) 'cresc)
- ((equal? name 'DecrescendoEvent) 'decr)
- (else #f)))
- (sp (ly:music-property ev 'span-direction)))
- (if (and (symbol? key) (ly:dir? sp))
- (if (= sp STOP)
- (assoc-remove! active key)
- (acons key
- (split-index (vector-ref voice-state-vec index))
- active))
- active)))
-
- (define (analyse-events active evs)
- "Run all analyzers on ACTIVE and EVS"
- (define (run-analyzer analyzer active evs)
- (if (pair? evs)
- (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
- active))
- (define (run-analyzers analyzers active evs)
- (if (pair? analyzers)
- (run-analyzers (cdr analyzers)
- (run-analyzer (car analyzers) active evs)
- evs)
- active))
- (sort ;; todo: use fold or somesuch.
- (run-analyzers (list analyse-absdyn-end analyse-span-event
- ;; note: tie-start/span comes after tie-end/absdyn.
- analyse-tie-end analyse-tie-start)
- active evs)
- active<?))
-
- ;; must copy, since we use assoc-remove!
- (if (< index (vector-length voice-state-vec))
- (begin
- (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
- (set! (span-state (vector-ref voice-state-vec index))
- (list-copy active))
- (helper (1+ index) active))))
-
- (helper 0 '()))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; let* with multiple values
+;;;
+;;; works like let*, but allows multiple names to take
+;;; multiple values.
+;;;
+;;; i.e.:
+;;; (multi-let* ((a b (values 1 2)))
+;;; (+ a b)) => 3
+;;;
+;;;
+
+(define-macro (multi-let* clauses . bodies)
+ (letrec ((split-last (lambda (head tail)
+ (if (null? (cdr tail))
+ (values (reverse! head) (car tail))
+ (split-last (cons (car tail) head)
+ (cdr tail))))))
+ (let ((clause1 (car clauses))
+ (rest (if (null? (cdr clauses))
+ bodies
+ `((multi-let* ,(cdr clauses) ,@bodies)))))
+ (if (null? (cddr clause1))
+ `(let (,clause1) ,@rest)
+ (call-with-values
+ (lambda () (split-last (list (car clause1)) (cdr clause1)))
+ (lambda (names val)
+ `(call-with-values (lambda () ,val)
+ (lambda ,names ,@rest))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define noticed '())
(define part-combine-listener '())
@@ -204,252 +59,706 @@
(ly:run-translator m2 part-combine-listener)
(ly:run-translator m1 part-combine-listener)
(set! (ly:music-property m 'split-list)
- (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
- (reverse! (cdr (assoc "two" noticed)) '())))
+ (determine-split-list (process-list (reverse! (cdr (assoc "one" noticed)) '()))
+ (process-list (reverse! (cdr (assoc "two" noticed)) '()))))
(set! noticed '())
m))
+(define (process-list evl)
+ (map (lambda (ev)
+ (cons (car ev) (map car (cdr ev))))
+ evl))
+
(define-public (determine-split-list evl1 evl2)
"EVL1 and EVL2 should be ascending"
- (let* ((pc-debug #f)
- (chord-threshold 8)
- (voice-state-vec1 (make-voice-states evl1))
- (voice-state-vec2 (make-voice-states evl2))
- (result (make-split-state voice-state-vec1 voice-state-vec2)))
-
- (define (analyse-time-step result-idx)
- (define (put x . index)
- "Put the result to X, starting from INDEX backwards.
-
-Only set if not set previously.
-"
- (let ((i (if (pair? index) (car index) result-idx)))
- (if (and (<= 0 i)
- (not (symbol? (configuration (vector-ref result i)))))
- (begin
- (set! (configuration (vector-ref result i)) x)
- (put x (1- i))))))
-
- (define (copy-state-from state-vec vs)
- (define (copy-one-state key-idx)
- (let* ((idx (cdr key-idx))
- (prev-ss (vector-ref result idx))
- (prev (configuration prev-ss)))
- (if (symbol? prev)
- (put prev))))
- (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<?))
- (pitches1 (sort (map (lambda (x) (ly:music-property x 'pitch))
- notes1)
- ly:pitch<?))
- (notes2 (note-events vs2))
- (durs2 (sort (map (lambda (x) (ly:music-property x 'duration))
- notes2)
- ly:duration<?))
- (pitches2 (sort (map (lambda (x) (ly:music-property x 'pitch))
- notes2)
- ly:pitch<?)))
- (cond ((> (length notes1) 1) (put 'apart))
- ((> (length notes2) 1) (put 'apart))
- ((= 1 (+ (length notes2) (length notes1))) (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)
- (or
- (< chord-threshold (ly:pitch-steps
- (ly:pitch-diff (car pitches1)
- (car pitches2))))
-
- ;; voice crossings:
- (> 0 (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 (< result-idx (vector-length result))
- (let* ((now-state (vector-ref result result-idx))
- (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 #f ; debug
- (display (list (when now-state) result-idx
- 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+ result-idx)))))))
-
- (define (analyse-a2 result-idx)
- (if (< result-idx (vector-length result))
- (let* ((now-state (vector-ref result result-idx))
- (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+ result-idx)))))
+ (multi-let*
+ ((moments (merge-moments evl1 evl2))
+ (notes1 (note-lengths evl1))
+ (notes2 (note-lengths evl2))
+ (span1 (spanner-lengths evl1))
+ (span2 (spanner-lengths evl2))
+ (measurepos (measure-positions moments evl1 evl2))
+ (music-end longest (music-end+longest evl1 evl2))
+ (measurelimits (measure-limits longest))
+ (types (make-type-context-list moments notes1 notes2
+ span1 span2 measurepos
+ measurelimits)))
+ (fix-rests-in-measures! types #f #f)
+ (let loop ()
+ (if (fix-blocks! types #f #t music-end)
+ (if (fix-rests-in-measures! types #f #f)
+ loop)))
+ (synthesize-types types)))
+
+(define (event-name event)
+ (ly:music-property event 'name))
+
+(define (ly:moment<=? m1 m2)
+ (not (ly:moment<? m2 m1)))
+
+;; fold with multiple arguments
+(define (multi-fold fun inits list)
+ (if (null? list) inits
+ (multi-fold fun
+ (apply fun (car list) inits)
+ (cdr list))))
+
+;; a type that represents the lengts of items (notes or spanners)
+(define make-item-length list)
+
+(define get-item first)
+(define start-moment second)
+(define end-moment third)
+
+(define mom-events:moment caar)
+(define mom-events:properties cdar)
+(define mom-events:events cdr)
+
+;; return lengths of the notes
+(define (note-lengths events-list)
+
+ (define (handle-events evmoment collected active)
+ (let ((moment (mom-events:moment evmoment))
+ (events (mom-events:events evmoment)))
+ (if active
+ (if (end-note? events)
+ (handle-events evmoment
+ (cons (make-item-length (car active)
+ (cdr active)
+ moment)
+ collected)
+ #f)
+ (list collected active))
+ (let ((start (extract-note events)))
+ (list collected
+ (if start (cons start moment) #f))))))
+
+ (reverse! (first (multi-fold handle-events '(() #f) events-list))))
+
+(define (extract-note event-list)
+ (let ((notes (filter (lambda (e)
+ (equal? (event-name e) 'NoteEvent))
+ event-list)))
+ (cond ((null? notes) #f)
+ ((pair? (cdr notes)) 'chord)
+ (else (car notes)))))
+
+(define (end-note? events)
+ (let loop ((events events)
+ (note-found? #f))
+ (if (null? events)
+ note-found?
+ (case (event-name (car events))
+ ((RestEvent MultiMeasureRestEvent) #t)
+ ((TieEvent) #f)
+ ((NoteEvent) (loop (cdr events) #t))
+ (else (loop (cdr events) note-found?))))))
+
+;; return a list of lists: (spanner span-start span-end)
+(define (spanner-lengths evlist)
+
+ (define spanners '(SlurEvent PhrasingSlurEvent BeamEvent
+ CrescendoEvent DecrescendoEvent))
+
+ (define (starting-spanners events)
+ (sort
+ (filter-map
+ (lambda (event)
+ (let ((name (event-name event)))
+ (and (member name spanners)
+ (equal? (ly:music-property event 'span-direction)
+ START)
+ name)))
+ events)
+ (lambda (s1 s2)
+ (string<? (symbol->string s1) (symbol->string s2)))))
+
+ (define (stopping-spanners events)
+ (append-map!
+ (lambda (event)
+ (let ((name (event-name event)))
+ (cond ((and (member name spanners)
+ (equal? (ly:music-property event 'span-direction)
+ STOP))
+ (list name))
+ ((member name '(CrescendoEvent DecrescendoEvent AbsoluteDynamicEvent))
+ (list 'CrescendoEvent 'DecrescendoEvent))
+ (else '() ))))
+ events))
+
+ ;; stop all given spanners and move them from active to collected
+ ;; this function checks each active spanner
+ (define (stop-spanners spanners moment collected active new-active)
+ (if (null? active)
+ (list collected (reverse! new-active))
+ (let ((name (caar active))
+ (start-moment (cdar active)))
+ (if (member name spanners)
+ (stop-spanners spanners
+ moment
+ (cons (make-item-length name start-moment moment)
+ collected)
+ (cdr active)
+ new-active)
+ (stop-spanners spanners
+ moment
+ collected
+ (cdr active)
+ (cons (car active) new-active))))))
+
+ ;; add new spanners to active
+ (define (start-spanners collected spanners active moment)
+ (list collected
+ (fold (lambda (spanner active)
+ (alist-cons spanner moment active))
+ active spanners)))
+
+ ;; add starting spanners to active and ended spanners to spanlist
+ (define (update-spanner-list events collected active)
+ (let ((moment (mom-events:moment events))
+ (events (mom-events:events events)))
+ (let ((stop-span (and (pair? active)
+ (stopping-spanners events)))
+ (start-span (starting-spanners events)))
+ (apply
+ (lambda (collected active)
+ (start-spanners collected start-span active moment))
+ (if stop-span
+ (stop-spanners stop-span moment collected active '())
+ (list collected active))))))
+
+ (sort (first (multi-fold update-spanner-list '(() ()) evlist))
+ (lambda (s1 s2) (ly:moment<? (start-moment s1)
+ (start-moment s2)))))
+
+(define (notes-next-moment notes moment)
+ (drop-while (lambda (n)
+ (ly:moment<=? (end-moment n) moment))
+ notes))
+
+(define (starting-note notes moment)
+ (and (pair? notes)
+ (let ((note (car notes)))
+ (and (equal? moment (start-moment note))
+ (get-item note)))))
+
+(define (current-note-end notes)
+ (end-moment (car notes)))
+
+(define (notes-resting-until? notes until)
+ (or (null? notes)
+ (ly:moment<=? until (start-moment (car notes)))))
+
+(define (notes-resting-at? notes moment)
+ (or (null? notes)
+ (ly:moment<? moment (start-moment (car notes)))))
+
+(define (make-span-moment spanner)
+ (cons spanner '()))
+
+(define span-moment:after car)
+(define span-moment:active cdr)
+
+;; this function modifies the previous moment to
+;; avoid creating to many cons cells every iteration
+;; However it doesn't modify the list of spanners
+(define (spanners-next-moment! span-moment moment)
+ (multi-let*
+ ((spanners (span-moment:after span-moment))
+ (active (span-moment:active span-moment))
+ (during-moment? (lambda (s)
+ (ly:moment<=? moment (end-moment s))))
+ (head tail (span (lambda (s)
+ (ly:moment<=? (start-moment s) moment))
+ spanners))
+ (new-active (append! (filter! during-moment? head)
+ (filter! during-moment? active))))
+ (cons tail new-active)))
+
+(define (spanners-equal? span1 span2 until-ev)
+ (let ((before-moment? (lambda (s)
+ (ly:moment<? (start-moment s) until-ev))))
+ (and (equal? (span-moment:active span1) (span-moment:active span2)) ;active spanners equal?
+ (equal? (take-while before-moment? (span-moment:after span1))
+ (take-while before-moment? (span-moment:after span2))))))
+
+(define (spanners-resting-until? span moment)
+ (and (null? (span-moment:active span)) ;no active spanners
+ (or (null? (span-moment:after span))
+ (ly:moment<=? moment (start-moment (car (span-moment:after span)))))))
+
+(define (equal-duration? note1 note2)
+ (equal? (ly:music-property note1 'duration)
+ (ly:music-property note2 'duration)))
+
+(define (equal-pitch? note1 note2)
+ (equal? (ly:music-property note1 'pitch)
+ (ly:music-property note2 'pitch)))
+
+(define (within-octave? note1 note2)
+ (let* ((p1 (ly:music-property note1 'pitch))
+ (p2 (ly:music-property note2 'pitch))
+ (steps (ly:pitch-steps (ly:pitch-diff p1 p2))))
+ (<= 1 steps 8)))
+
+(define (type-at-moment moment notes1 notes2 span1 span2)
+ (let ((note1 (starting-note notes1 moment))
+ (note2 (starting-note notes2 moment)))
+ (cond ((or (eq? note1 'chord)
+ (eq? note2 'chord))
+ '(poly2 apart #t))
+ ((and note1 note2)
+ (cond ((not (equal-duration? note1 note2))
+ '(poly2 apart #t))
+ ((not (spanners-equal? span1 span2 (current-note-end notes1)))
+ '(mono apart #t))
+ ((equal-pitch? note1 note2)
+ '(mono unisono #t))
+ ((within-octave? note1 note2)
+ '(mono chords #t))
+ (else '(mono apart #t))))
+ (note1 (cond ((not (notes-resting-until? notes2 (current-note-end notes1)))
+ '(poly1 apart #t))
+ ((not (spanners-resting-until? span2 (current-note-end notes1)))
+ '(voice1 apart #t))
+ (else '(voice1 solo1 #t))))
+ (note2 (cond ((not (notes-resting-until? notes1 (current-note-end notes2)))
+ '(poly1 apart #t))
+ ((not (spanners-resting-until? span1 (current-note-end notes2)))
+ '(voice2 apart #t))
+ (else '(voice2 solo2 #t))))
+ ((and (notes-resting-at? notes1 moment)
+ (notes-resting-at? notes2 moment))
+ '(none unisilence #f))
+ (else 'keep))))
+
+(define (synthesize-types types)
+ (map (lambda (type)
+ (cons (tc-moment type)
+ (second (tc-types type))))
+ types))
+
+;; efficient modifying unique
+(define (unique! lst)
+ (let uniquify ((lst lst))
+ (if (pair? lst)
+ (let* ((elem (car lst))
+ (next (drop-while (lambda (e)
+ (equal? elem e))
+ lst)))
+ (set-cdr! lst next)
+ (uniquify next))))
+ lst)
+
+;; Find the next context such that moment is
+;; smaller that the next moment of context.
+(define (next-moment-fun get-moment)
+ (define (next-moment mc moment)
+ (let ((next (cdr mc)))
+ (cond ((null? next) mc)
+ ((ly:moment<? moment (get-moment (car next))) mc)
+ (else (next-moment next moment)))))
+ next-moment)
+
+(define event-list-next
+ (next-moment-fun caar))
+
+(define moment-context-next
+ (next-moment-fun car))
+
+(define (merge-moments evl1 evl2)
+ (unique! (merge (map caar evl1)
+ (map caar evl2)
+ ly:moment<?)))
+
+(define (make-context value adv-func)
+ (cons value adv-func))
+
+(define context:value car)
+(define context:advance-func cdr)
+
+(define (make-notes-context notes)
+ (make-context notes notes-next-moment))
+
+(define (make-spanner-context spanner)
+ (make-context (make-span-moment spanner) spanners-next-moment!))
+
+(define (make-event-list-context evl)
+ (make-context evl event-list-next))
+
+(define (make-moment-context mc)
+ (make-context mc moment-context-next))
+
+(define-record-type :type-context
+ (make-type-context types moment measurepos minim-block minim-sep)
+ type-context?
+ (types tc-types tc-set-types!)
+ (moment tc-moment)
+ (measurepos tc-measurepos)
+ (minim-block tc-minimum-block)
+ (minim-sep tc-minimum-separation))
+
+(define null-moment (ly:make-moment 0 0))
+
+;; I asume that moments at the beginning of a bar don't
+;; have a grace timing, otherwise we might have a bug
+;; here.
+(define (tc-beginning-of-bar? context)
+ (equal? (tc-measurepos context) null-moment))
+
+;; for each moment, advance the context using it's advancement
+;; function, pass the values values to fun, and collect the
+;; results.
+(define (map-with-contexts fun moments . contexts)
+ (let mwc-aux
+ ((moments moments)
+ (contexts (map context:value contexts))
+ (adv-funcs (map context:advance-func contexts))
+ (acc '()))
+ (if (null? moments)
+ (reverse! acc)
+ (let* ((moment (car moments))
+ (contexts (map (lambda (f c) (f c moment))
+ adv-funcs
+ contexts))
+ (value (apply fun moment contexts)))
+ (mwc-aux (cdr moments) contexts adv-funcs (cons value acc))))))
+
+(define (find-last pred? lst)
+ (let aux ((lst lst) (last #f))
+ (cond ((null? lst) last)
+ ((pred? (car lst))
+ (aux (cdr lst) (car lst)))
+ (else
+ (aux (cdr lst) last)))))
+
+(define (music-end+longest evl1 evl2)
+ (let* ((find-event (lambda (evl)
+ (find (lambda (e)
+ (memq (event-name e)
+ '(NoteEvent RestEvent MultiMeasureRestEvent)))
+ (cdr evl))))
+ (last1 (find-last find-event evl1))
+ (last2 (find-last find-event evl2))
+ (end1 (ly:add-moment (caar last1)
+ (ly:music-length (find-event last1))))
+ (end2 (ly:add-moment (caar last2)
+ (ly:music-length (find-event last2)))))
+ (if (ly:moment<? end1 end2)
+ (values end2 evl2)
+ (values end1 evl1))))
+
+(define (measure-positions moments evl1 evl2)
+ (map-with-contexts
+ (lambda (moment events1 events2)
+ (cond ((equal? (mom-events:moment (car events1)) moment)
+ (cons moment (cdr (assq 'measurePosition
+ (mom-events:properties (car events1))))))
+ ((equal? (mom-events:moment (car events2)) moment)
+ (cons moment (cdr (assq 'measurePosition
+ (mom-events:properties (car events2))))))
+ (else #f))) ; shouldn't happen
+ moments
+ (make-event-list-context evl1)
+ (make-event-list-context evl2)))
+
+(define (collect-property-values evl prop)
+ (filter-map
+ (lambda (events)
+ (let ((moment (mom-events:moment events))
+ (pair (assq prop (mom-events:properties events))))
+ (if pair (cons moment (cdr pair)) #f)))
+ evl))
- (define (analyse-solo12 result-idx)
-
- (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 result-idx)) 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) '())))
- ;; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n"))
- (cond ((not (equal? (configuration now-state) 'apart))
- current-idx)
- ((> (length silent-notes) 0) start-idx)
- ((not solo-state)
- (put-range type start-idx current-idx)
- current-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)))))
- ;; try-solo
- start-idx))
-
- (define (analyse-moment result-idx)
- "Analyse 'apart starting at RESULT-IDX. Return next index. "
- (let* ((now-state (vector-ref result result-idx))
- (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 " result-idx " moment " (when now-state) vs1 vs2 "\n"))
- (max
- ;; we should always increase.
- (cond ((and (= n1 0) (= n2 0))
- (put 'apart-silence)
- (1+ result-idx))
- ((and (= n2 0)
- (equal? (when vs1) (when now-state))
- (null? (previous-span-state vs1)))
- (try-solo 'solo1 result-idx result-idx))
- ((and (= n1 0)
- (equal? (when vs2) (when now-state))
- (null? (previous-span-state vs2)))
- (try-solo 'solo2 result-idx result-idx))
-
- (else (1+ result-idx)))
- ;; analyse-moment
- (1+ result-idx))))
+(define (measure-limits evl)
+ (let ((fractions (collect-property-values evl 'timeSignatureFraction)))
+ (map (lambda (prop)
+ (let ((moment (car prop))
+ (minim-block (calc-block-length (cdr prop)))
+ (minim-sep (calc-separation (cdr prop))))
+ (list moment minim-block minim-sep)))
+ fractions)))
+
+(define (calc-block-length fraction)
+ (let ((bars (if (< (car fraction) 4)
+ 3 2)))
+ (ly:make-moment (* (car fraction) bars)
+ (cdr fraction))))
- (if (< result-idx (vector-length result))
- (if (equal? (configuration (vector-ref result result-idx)) 'apart)
- (analyse-solo12 (analyse-moment result-idx))
- (analyse-solo12 (1+ result-idx))))) ; 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 #f ;; pc-debug
- (display result))
- result))
+(define (calc-separation fraction)
+ (let ((bars (if (< (car fraction) 4)
+ 2 1)))
+ (ly:make-moment (* (car fraction) bars)
+ (cdr fraction))))
+
+(define (make-type-context-list moments notes1
+ notes2 span1 span2
+ measurepos measurelimits)
+ (let ((type-context-list
+ (map-with-contexts
+ (lambda (moment notes1 notes2 span1 span2 measurepos measurelimits)
+ (let ((type (type-at-moment moment notes1 notes2
+ span1 span2)))
+ (make-type-context type
+ moment
+ (cdar measurepos) ; extract value from alist
+ (second (car measurelimits))
+ (third (car measurelimits)))))
+ moments
+ (make-notes-context notes1)
+ (make-notes-context notes2)
+ (make-spanner-context span1)
+ (make-spanner-context span2)
+ (make-moment-context measurepos)
+ (make-moment-context measurelimits))))
+ (follow-kept-types! type-context-list #f)
+ type-context-list))
+
+(define (follow-kept-types! context prev)
+ (if (pair? context)
+ (let ((types (tc-types (car context))))
+ (if (eq? types 'keep)
+ (let ((new-value (list (first prev) (second prev) #f)))
+ (tc-set-types! (car context) new-value)
+ (follow-kept-types! (cdr context) new-value))
+ (follow-kept-types! (cdr context) types)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; The following rules are used for each bar to ensure that the voices
+;; and rests in the bar flow naturally, for example rests will not
+;; disappear into nothing:
+;;
+;; - Make a new solovoice
+;;
+;; * only when preceded by
+;; - monophonic music
+;; - merged rest (unisilence)
+;;
+;; * never when followed by two printed voices with at least one
+;; resting
+;;
+;; - Make a merged rest
+;;
+;; * only when preceded by
+;; - music without printed rest
+;; - merged rest
+;;
+;; * never when followed by two printed voices with at least one
+;; resting
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (two-voices-and-rest? context prev)
+ (cond ((null? context) #f)
+ ((tc-beginning-of-bar? (car context)) #f) ; next bar
+ (else
+ (let* ((types (tc-types (car context)))
+ (type1 (first types)))
+ (cond ((memq type1 '(poly2 mono)) #f)
+ ((eq? type1 'poly1) #t)
+ ;; type1 == voice1, voice2, or none
+ ((eq? (second types) 'apart) #t)
+ ((and (eq? type1 'voice1)
+ (eq? (first prev) 'voice2)) #t)
+ ((and (eq? type1 'voice2)
+ (eq? (first prev) 'voice1)) #t)
+ (else (two-voices-and-rest? (cdr context) types)))))))
+
+(define (fix-rests-in-measures! context modified? prev)
+ (if (null? context) modified?
+ (let* ((types (tc-types (car context)))
+ (type1 (first types))
+ (fix-next (lambda ()
+ (fix-rests-in-measures! (cdr context) modified? types)))
+ (modify-fix-next (lambda ()
+ (let ((new-value `(,type1 apart ,(third types))))
+ (tc-set-types! (car context) new-value)
+ (fix-rests-in-measures! (cdr context) #t new-value)))))
+ (cond ((eq? (second types) 'apart)
+ (fix-next))
+ ((and (memq type1 '(voice1 voice2))
+ (put-voice-apart? types context prev))
+ (modify-fix-next))
+ ((and (eq? type1 'none)
+ (put-rests-apart? types context prev))
+ (modify-fix-next))
+ (else (fix-next))))))
+
+;; Check if the voice/rests can be merged.
+;; These functions are difficult to understand.
+;; * If we are at the beginning of a bar:
+;; -> search forward to see if it is followed by two printed
+;; voices with at least one rest.
+;; * If we have a monophonic voice preceding we have to check
+;; again the following notes.
+;; * Otherwise we can take the previous value, since for a merged
+;; solo or rests the next notes have been checked already, and
+;; for polyphonic music the notes will never be merged
+;; * merging rests is also allowed after polyphonic music without
+;; rests (poly2)
+
+(define (put-voice-apart? types context prev)
+ (if (or (tc-beginning-of-bar? (car context))
+ (eq? (first prev) 'mono))
+ (two-voices-and-rest? (cdr context) types)
+ (eq? (second prev) 'apart)))
+
+(define (put-rests-apart? types context prev)
+ (if (or (tc-beginning-of-bar? (car context))
+ (memq (first prev) '(mono poly2)))
+ (two-voices-and-rest? (cdr context) types)
+ (eq? (second prev) 'apart)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; The following rules are used to make sure that a solo or a due part
+;; is only used for continguous blocks, to prevent to many changes in
+;; the score.
+;;
+;; - all notes in a block should be part of the same kind (solo, a
+;; due, chords).
+;;
+;; - a rest is part of the block only if the part of the block that
+;; follows the rest is at least as long as the rest.
+;;
+;; - if a rest is larger than "minimum-separation" it will not be part
+;; of the block
+;;
+;; - for a block to be put into a kind (solo, ...), it has to have at
+;; least three notes, and must have a minimum length of
+;; "minimum-block".
+;;
+;; - an isolated block, preceded and followed by a large rest can have
+;; any size.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; puts voices apart for blocks that aren't big enough. The
+;; separate? argument indicates if the block should be considered
+;; separate from other blocks.
+(define (fix-blocks! context modified? separate? music-end)
+ (if (null? context)
+ modified?
+ (let* ((types (tc-types (car context))))
+ (cond
+ ((eq? (first types) 'none) ; skip rests and check if the
+ (receive (separate? next) ; next block will be separate
+ (skip-to-next context music-end)
+ (fix-blocks! next modified? separate? music-end)))
+ ((eq? (second types) 'apart) ; skip 'apart
+ (fix-blocks! (cdr context) modified? #f music-end))
+ (else
+ ;; type1 == voice1, voice2, mono
+ (receive (modified2? next-context)
+ (fix-following-block! context (second types)
+ separate? music-end)
+ (fix-blocks! next-context
+ (or modified? modified2?)
+ #f music-end)))))))
+
+(define (fix-following-block! context type separate? music-end)
+ (multi-let*
+ ((after-context num-notes (take-block context type 0 music-end))
+ (block-length (duration-between context after-context music-end))
+ (separate-after? next-context (skip-to-next after-context music-end))
+ (modify? (and (not (and separate-after? separate?)) ; not isolated
+ (or (< num-notes 3)
+ (ly:moment<? block-length
+ (tc-minimum-block (car context)))))))
+ (if modify?
+ (put-block-apart! context after-context)
+ (adjust-rest-types! context after-context type))
+ (values modify? after-context)))
+
+(define (put-block-apart! context after-context)
+ (if (not (eq? context after-context))
+ (let ((types (tc-types (car context))))
+ (if (not (eq? (first types) 'none)) ; don't put rests apart here!
+ (tc-set-types! (car context)
+ (list (first types) 'apart (third types))))
+ (put-block-apart! (cdr context) after-context))))
+
+(define (adjust-rest-types! context after-context type)
+ (if (not (eq? context after-context))
+ (let ((types (tc-types (car context))))
+ (if (eq? (first types) 'none)
+ (tc-set-types! (car context)
+ (list (first types) type (third types))))
+ (adjust-rest-types! (cdr context) after-context type))))
+
+(define (take-block context block-type numnotes music-end)
+ (let ((types (tc-types (car context))))
+ (cond ((eq? (first types) 'none)
+ (receive (succeed? next-context numnotes)
+ (try-after-rest context block-type numnotes music-end)
+ (if succeed?
+ (take-block next-context block-type numnotes music-end)
+ (values context numnotes))))
+ ((eq? (second types) block-type)
+ (take-block (cdr context) block-type
+ (if (third types) (+ numnotes 1) numnotes)
+ music-end))
+ (else
+ (values context numnotes)))))
+
+(define (duration-between context1 context2 music-end)
+ (let ((get-moment (lambda (context)
+ (if (null? context) music-end
+ (tc-moment (car context))))))
+ (ly:sub-moment (get-moment context2)
+ (get-moment context1))))
+
+(define (skip-to-next context music-end)
+ (receive (length next) (skip-rest context music-end)
+ (values (ly:moment<=? (tc-minimum-separation (car context)) length)
+ next)))
+
+(define (skip-rest context music-end)
+ (let* ((next (drop-while (lambda (c)
+ (eq? (first (tc-types c)) 'none))
+ context))
+ (length (duration-between context next music-end)))
+ (values length next)))
+
+(define (try-after-rest context block-type numnotes music-end)
+ (receive (rest-length block-begin)
+ (skip-rest context music-end)
+ (if (ly:moment<=? (tc-minimum-separation (car context)) rest-length)
+ (values #f context numnotes)
+ (receive (succeed? next-block numnotes2)
+ (take-minimum-block rest-length block-begin
+ block-type numnotes music-end)
+ (if succeed?
+ (values #t next-block numnotes2)
+ (values #f context numnotes))))))
+
+;; Takes the smallest block that is at least min-length long.
+;; If there is no such block return the start-position
+(define (take-minimum-block min-length start block-type numnotes music-end)
+ (let take-one ((context start)
+ (numnotes numnotes))
+ (let ((types (tc-types (car context)))
+ (length (duration-between start context music-end)))
+ (cond ((ly:moment<=? min-length length) ; block is large enough
+ (values #t context numnotes))
+ ((eq? (second types) block-type) ; same type: continue
+ (take-one (cdr context)
+ (if (third types) (+ numnotes 1) numnotes)))
+ ((eq? (first types) 'none) ; rest
+ (receive (succeed? block-end numnotes2)
+ (try-after-rest context block-type music-end)
+ (if succeed?
+ (take-one block-end numnotes2) ;continue
+ ;; otherwise succeed if the distance to the next
+ ;; notes is least min-length
+ (multi-let* ((l next-block (skip-rest block-end))
+ (length (duration-between context block-end music-end)))
+ (if (ly:moment<? length min-length)
+ (values #f context numnotes)
+ (values #t block-end numnotes2))))))
+ (else ; end of block before min-length
+ (values #f numnotes start))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; autochange - fairly related to part combining._______________________________________________
lilypond-devel mailing list
lilypond-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/lilypond-devel
