? 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  <address@hidden>
+
+	* 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  <address@hidden>
 
 	* 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 <address@hidden>
 
-;; 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.