staves.lisp

;; -*- lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;**************************************************************************************************
;; FOMUS
;; staves.lisp
;;**************************************************************************************************

(in-package :fomus)
(compile-settings)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STAVES/CLEFS

(declaim (type boolean *auto-staff/clef-changes*))
(defparameter *auto-staff/clef-changes* t)

(declaim (type symbol *auto-staff/clefs-plugin* *auto-staff/clefs-module*))
(defparameter *auto-staff/clefs-plugin* nil)
(defparameter *auto-staff/clefs-module* t)
(declaim (inline auto-clefs-fun))
(defun auto-clefs-fun () (if (truep *auto-staff/clefs-module*) :staves/clefs1 *auto-staff/clefs-module*))

(declaim (type (real 0) *clef-force-clef-change-dist*))
(defparameter *clef-force-clef-change-dist* 2) ; 2 can be nil

(declaim (type #-allegro (float 0 1) #+allegro float *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*))
(defparameter *clef-change-clef-penalty* (float 1)) ; 1
(defparameter *clef-change-staff-penalty* (float 1/2)) ; 1/4 should probably be less than change-clef-penalty

(defparameter *clef-polyphony-perbeat-penalty* (float 1/3)) ; 1/16 per beat
(defparameter *clef-order-perbeat-penalty* (float 1/8)) ; 1/16

;; rests should be filtered out before this function is called
;; staff is a number
(declaim (type cons *clef-midwhites* *clef-switchthrs* *clef-list*))
(declaim (special *clef-midwhites* *clef-switchthrs* *clef-list*))
(defun clefs-getclef (clef events staff)
  (declare (type symbol clef) (type list events) (type (integer 0) staff))
  (let ((mi (mloop for e of-type noteex in events minimize (event-writtennote e))) ; GUESS WRITTENNOTE
	(ma (mloop for e of-type noteex in events maximize (event-writtennote e))))
    (flet ((cf () ; choose clef--mi and ma assumed to be written notes
	     (let ((m (/ (+ (notetowhite mi) (notetowhite ma)) 2)))
	       (loop-return-argmin (diff (the integer (lookup cl *clef-midwhites*)) m)
				   for cl of-type symbol in *clef-list*))))
      (if clef
	  (if (or (null events)
		  (let ((cd (lookup clef *clef-switchthrs*)))
		    (declare (type cons cd))
		    (let ((u (cdr cd)) (l (car cd)))
		      (declare (type (or integer null) u l))
		      (and (if l (>= mi l) t) (if u (<= ma u) t)))))
	      clef (cf))
	  (if events (cf) (or (the symbol (nth staff *clef-list*)) (the symbol (last-element *clef-list*))))))))

(declaim (type (integer 1) *staff-engine-heap*))
(defparameter *staff-engine-heap* 30)

(defstruct (clefnode (:copier nil) (:predicate clefnodep))
  (sc 0.0 :type #-allegro (float 0) #+allegro float)
  (lo 0 :type (rational 0))
  (lg 0 :type (rational 0))
  (ics #() :type (vector symbol))
  (cs #() :type (vector symbol))
  (lvs #() :type (vector list))
  (ret nil :type list)
  (evs nil :type list)
  (o 0 :type (rational 0))
  (co 0 :type (integer 0))) ; ics is vector of init-clef, cs is vector of clefs, lvs = vector of last voices
(defun clefs-bylegscore (events instr name)
  (let ((nst (instr-staves instr))
	(co 0))
    (declare (type (integer 0) co))
    (labels ((cm (vs al &optional (s 0)) ; all combinations of staff/voice assignmets (list of lists of (staff . voice))
	       (declare (type list vs) (type list al) (type (integer 0) s))
	       (when vs
		 (loop for i of-type (integer 0) in (or al (loop for i0 from s below nst collect i0)) nconc
		       (loop for j of-type list in (or (cm (rest vs) al i) '(nil)) collect
			     (cons (cons i (first vs)) j))))))
      (flet ((scorefun (no) (declare (type clefnode no)) (cons (clefnode-sc no) (clefnode-co no)))
	     (expandfun (no)
	       (declare (type clefnode no))
	       (when (> (clefnode-co no) co) ;; progress
		 (setf co (clefnode-co no))
		 (print-dot))
	       (let ((o (event-off (first (clefnode-evs no)))))
		 (multiple-value-bind (al es rs vs gd) ; es = events at cur. offset, rs = rest of evs, vs = sorted voices, gd = 0 or effgracedur if grace notes
		     (loop
		      with g = (event-grace (first (clefnode-evs no))) and al and pe
		      for rs on (clefnode-evs no) for e of-type noteex = (first rs)
		      while (and (= (event-off e) o) (eql (event-grace e) g) (or (null pe) (equal (event-userstaff e) (event-userstaff pe))))
		      collect e into es
		      do (setf al (event-userstaff e) pe e)
		      collect (event-voice* e) into v
		      when g maximize (event-graceeffdur e) into gd
		      finally (return (values al es rs (sort (delete-duplicates v) #'<) #-clisp gd #+clisp (or gd 0))))
		   (loop 
		    with nco = (if (or (null (clefnode-o no)) (> o (clefnode-o no))) (1+ (clefnode-co no)) (clefnode-co no)) 
		    for vas of-type cons in (cm vs (loop for e of-type (integer 0) in al if (< e nst) collect e else do
							 (error "Invalid staff number ~S in :STAFF mark at offset ~S, part ~S" (1+ e) (coerce o 'float) name))) ; iterate over all possible arrangements, vas is a possible combination of (cons staff voice)
		    collect (loop
			     with sc = (clefnode-sc no) ; score
			     and ics = (copy-seq (clefnode-ics no)) ; initial clefs
			     and cs = (copy-seq (clefnode-cs no)) ; current clefs
			     and lvs = (copy-seq (clefnode-lvs no)) ; last voices
			     for sv of-type cons in (split-into-groups vas #'car) ; sv is list of (cons staff voice) for one staff
			     nconc (let* ((vv (mapcar #'cdr sv)) ; vv = voices for this staff
					  (ve (remove-if-not (lambda (x) (declare (type noteex x)) (find (event-voice* x) vv)) es))) ; ve = events for this staff 
				     (let ((s (car (first sv))) ; s = staff
					   (uc (find-if #'identity ve :key #'event-userclef)))
				       (declare (type (integer 0) s) (type (or note null) uc))
				       (let ((c0 (svref cs s))
					     (c (or uc ; override
						    (clefs-getclef nil ve s)))) ; c = new clef (maybe)
					 (if (svref (clefnode-ics no) s)
					     (when (and (not (eq c c0))	; clef change suggested
							(or uc ; forced override
							    (eq c (clefs-getclef c0 ve s)) ; supported by necessary change
							    (loop with li and oo of-type (rational 0) and gg ; look ahead to be sure
								  for e of-type noteex in rs
								  when (find (event-voice* e) vv) do
								  (if li
								      (if (and (= (event-off e) oo) (eql (event-grace e) gg))
									  (push e li)
									  (if (eq c0 (clefs-getclef nil li s)) ; goes back to original clef
									      (return)
									      (if (or (and *clef-force-clef-change-dist*
											  (> (- oo o) *clef-force-clef-change-dist*)) ; going too far
										      (eq c (clefs-getclef c0 li s))) ; finally supported by necessary change
										  (return t)
										  (setf li (list e)))))	; necessary to change
								      (setf oo (event-off e) gg (event-grace e) li (list e)))
								  finally
								  (return (unless (or (null li) (eq c0 (clefs-getclef nil li s))) ; goes back to original clef
									    (or (and *clef-force-clef-change-dist*
										     (> (- oo o) *clef-force-clef-change-dist*)) ; going too far
										(eq c (clefs-getclef c0 li s))))))))
					       (setf (svref cs s) c ve (cons (let ((x (copy-event (first ve))))
									       (addmark x (list :clef c)) x)
									     (rest ve)))
					       (incf sc *clef-change-clef-penalty*))
					     (setf (svref ics s) c (svref cs s) c)))
				       (mapc (lambda (v)
					       (declare (type (integer 1) v))
					       (let ((p (position v lvs :test #'find)))	; p = last staff this voice was on
						 (when (or (null p) (/= p s))
						   (incf sc *clef-change-staff-penalty*)
						   (when p (setf (svref lvs p) (remove v (svref lvs p))))
						   (push v (svref lvs s)))))
					     vv)
				       (if (> nst 1)
					   (mapcar (lambda (x) (declare (type noteex x)) (copy-event x :voice (cons (1+ s) (event-voice* x)))) ve)
					   (copy-list ve)))) into ret
			     finally
			     (incf sc (* (+ (* (loop for e across lvs sum (max (1- (length e)) 0)) ; avoid excessive polyphony on one staff
					       *clef-polyphony-perbeat-penalty*)
					    (* (loop ; clef order
						with xl = (loop for x across cs when x collect (position x +clefs+ :key #'car)) and xh #-clisp while #-clisp xl
						for e of-type (integer 0) = #-clisp (pop xl) #+clisp (if xl (pop xl) (loop-finish))
						count (or (when xh (< (min-list xh) e)) (when xl (> (or (max-list xl) -1) e))) 
						do (push e xh))
					       *clef-order-perbeat-penalty*))
					 (max (- o (clefnode-lo no)) (clefnode-lg no))))
			     (return (make-clefnode :sc sc :lo o :lg gd :ics ics :cs cs :lvs lvs :ret (nconc ret (clefnode-ret no)) :evs rs :o o :co nco))))))) ; ret is out of order
	     (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2)))
	     (remscoregreaterfun (r1 r2)
	       (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2))
	       (if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2))))
	     (solutfun (no) (declare (type clefnode no)) (null (clefnode-evs no))))
	(let ((*clef-list* (force-list (instr-clefs instr))))
	  (multiple-value-bind (*clef-midwhites* *clef-switchthrs*) ; so = middle whitenotes, sx = switching thresholds
	      (loop
	       with pp and l = (instr-cleflegls instr) 
	       for (c . p) of-type (symbol . (or integer null)) in +clefs+
	       when (find c *clef-list*)
	       do (setf pp (notetowhite p))
	       and collect (cons c pp) into r
	       and collect (cons c (cons (whitetonote (- pp
							 (* (if (numberp l) l
								(loop
								 with l0 of-type integer
								 for z of-type (or (integer 1) cons) in l
								 for (e a1 a2) of-type ((or (integer 1) symbol) symbol (or (integer 1) null)) in (force-list z)
								 if (numberp e) do (setf l0 e)
								 else if (and (eq e c) (eq a1 :dn)) do (return a2)
								 finally (return l0))) 2)
							 5))
					 (whitetonote (+ pp
							 (* (if (numberp l) l
								(loop
								 with l0 of-type integer
								 for z of-type (or (integer 1) cons) in l
								 for (e a1 a2) of-type ((or (integer 1) symbol) symbol (or (integer 1) null)) in (force-list z)
								 if (numberp e) do (setf l0 e)
								 else if (and (eq e c) (eq a1 :up)) do (return a2)
								 finally (return l0))) 2)
							 5)))) into re
	       finally
	       (setf (cadr (first re)) nil
		     (cddr (last-element re)) nil)
	       (return (values r re)))
	    (let ((n (or (let ((*staff-engine-heap* (max (roundint (* *staff-engine-heap* *quality*)) 1)))
			   (bfs*-engine (list (make-clefnode :ics (make-array nst :initial-element nil)
							   :cs (make-array nst :initial-element nil)
							   :lvs (make-array nst :initial-element nil)
							   :evs events))
				      #'scorefun
				      #'expandfun
				      #'solutfun
				      :heaplim *staff-engine-heap*
				      :scoregreaterfun #'scoregreaterfun
				      :remscoregreaterfun #'remscoregreaterfun))
			 (error "Cannot find staff/clef assignments for part ~S" name))))
	      (values (clefnode-ret n)
		      (loop for i from 0 below nst collect
			    (list :clef (or (svref (clefnode-ics n) i)
					    (clefs-getclef nil nil i))
				  (1+ i)))))))))))

(declaim (inline load-staff/clef-modules))
(defun load-staff/clef-modules ()
  (unless (eq (auto-clefs-fun) :staves/clefs1) (load-fomus-module (auto-clefs-fun))))

(defun clefs (parts)
  (loop
     for p of-type partex in parts
     for ns = (instr-staves (part-instr p))
     do (rmprop p :clef) 
     if (is-percussion p) do
       (loop for i from 1 to ns do (addprop p (list :clef :percussion i)))
       (loop for g of-type cons in (split-into-groups (part-events p) #'event-voice*) do
	    (get-usermarks g :staff :startstaff- :staff- :endstaff-
			   (lambda (e s)
			     (declare (type (or noteex restex) e) (type list s))
			     (when (> ns 1) (setf (event-staff* e) (1- (first s))))) (part-name p)))
       (loop for e of-type (or noteex restex) in (part-events p) do (rmmark e :clef))
     else do ; not percussion..., voices aren't separated yet!--separate voices
       (loop for g of-type cons in (split-into-groups (part-events p) #'event-voice*) do
	    (get-usermarks g :staff :startstaff- :staff- :endstaff-
			   (lambda (e s)
			     (declare (type (or noteex restex) e) (type list s))
			     (if (notep e) (setf (event-userstaff e) (mapcar #'1- (force-list s))))
			     (addmark e (cons :staff s))
			     #|(if (notep e) (setf (event-userstaff e) (mapcar #'1- (force-list s))) (addmark e (print (cons :staff s))))|#)
			   (part-name p)))
       (multiple-value-bind (no re) (split-list (part-events p) #'notep)
	 (get-usermarks no :clef :startclef- :clef- :endclef-
			(lambda (e c)
			  (declare (type (or noteex restex) e) (type list c))
			  (setf (event-userclef e) (first c)))
			(part-name p))
	 (multiple-value-bind (evs prs)
	     (if (eq (auto-clefs-fun) :staves/clefs1)
		 (clefs-bylegscore no (part-instr p) (part-name p))
		 (call-module (auto-clefs-fun) (list "Unknown staff/clefs assignment module ~S" *auto-staff/clefs-module*) no (part-instr p) (part-name p)))
	   (setf (part-events p) (sort (nconc re evs) #'sort-offdur))
	   (mapc (lambda (x) (declare (type cons x)) (addprop p x)) prs)))
       (loop ; temporarily assign rests to staves (will become defaults if distr-rests isn't run)
	  for g of-type cons in (split-into-groups (part-events p) #'event-voice*)
	  do (loop
		with s of-type (or list (integer 1))
		for e of-type (or noteex restex) in (sort g #'sort-offdur)
		if (and (restp e) (null (getmark e :staff))) do (if (listp s) (push e s) (setf (event-staff* e) s))
		else do
		  (let ((v (if (restp e) (second (popmark e :staff)) (event-staff e))))
		    (when v
		      (when (listp s) 
			(mapc (lambda (x) (declare (type restex x)) (setf (event-staff* x) v)) s))
		      (setf s v)))))))

(defun clefs-generic (parts)
  (loop for p of-type partex in parts
	for ns = (instr-staves (part-instr p)) do
	(get-usermarks (part-events p) :staff :startstaff- :staff- :endstaff-
		       (lambda (e s)
			 (declare (type (or noteex restex) e) (type list s))
			 (when (> ns 1) (setf (event-staff* e) (first s))))
		       (part-name p))
	(loop for ee of-type cons in (split-into-groups (part-events p) #'event-staff) do
	      (get-usermarks (part-events p) :clef :startclef- :clef- :endclef-
			     (lambda (e c)
			       (declare (type (or noteex restex) e) (type list c))
			       (setf (event-userclef e) (first c))) (part-name p))
	      (loop with s
		    for e of-type (or noteex restex) in (sort ee #'sort-offdur)
		    unless (eq s (event-userclef e)) do (addmark e :clef) (setf s (event-userclef e))))))

(defun clean-clefs (pts)
  (loop for p of-type partex in pts
	do (loop for s from 1 to (instr-staves (part-instr p)) do
		 (loop with x 
		       for m of-type meas in (reverse (part-meas p))
		       do (loop
			   for p = e
			   for e of-type (or noteex restex)
			   in (reverse (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-staff x) s)) (meas-events m))) 
			   when (or (restp e) (and p (< (event-endoff e) (event-off p)))) do (setf x nil)
			   if (and (notep e) (or-list (force-list (event-tielt e))))
			   do (let ((x0 (popmark e :clef)))
				(when (and x0 (null x)) (setf x x0)))
			   else if x do (rmmark e :clef) (addmark e x) (setf x nil)))
		 (loop with x 
		       for m in (part-meas p)
		       do (loop for e of-type (or noteex restex)
				in (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-staff x) s)) (meas-events m))
				for m = (getmark e :clef)
				when m do (if (eq (second m) x) (rmmark e :clef) (setf x (second m)))))) (print-dot)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DISTRIBUTE RESTS

(declaim (type (member nil t :some :all) *grandstaff-hide-rests*)
	 (type (real (0)) *min-grandstaff-hide-rests-dur*))
(defparameter *grandstaff-hide-rests* t) ; nil (t or :some) or :all, can override in part properties?
(defparameter *min-grandstaff-hide-rests-dur* 1)

(declaim (type symbol *auto-distr-rests-plugin* *auto-distr-rests-module*))
(defparameter *auto-distr-rests-plugin* nil)
(defparameter *auto-distr-rests-module* t)
(declaim (inline auto-distr-rests-fun))
(defun auto-distr-rests-fun () (if (truep *auto-distr-rests-module*) :rests1 *auto-distr-rests-module*))

;; call AFTER ass-voices but BEFORE anything else (need to know where the rests are)
;; assigns all rests to staves and hides some rests
;; if other voice in OTHER staff crosses to staff w/ rests & includes notes AND flag set & >= min dur AND region includes beg/end of measure, make rests invisible (do in distr-rests)
;; (if rests hidden at beg. of measure, don't hide rest of measure)
(defun distr-rests-byconfl (parts)
  (declare (type list parts))
  (loop
   with rl of-type list ; (cons (cons (rational 0) (rational 0)) list)
   and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible
   for p of-type partex in (remove-if #'is-percussion parts)
   for sv = (> (instr-staves (part-instr p)) 1) do
   (loop
    for v in (loop with v for m of-type meas in (part-meas p) do
		   (loop for e of-type (or noteex restex) in (meas-events m) do (pushnew (event-voice* e) v))
		   finally (return v)) do
    (loop
     with s and r and r0 and r1	; r is rests up to endoff falling even w/ beat, r0 = remaining, r1 = to turn invisible
     and ae0 = (remove-if-not #'notep (loop for m of-type meas in (part-meas p) append (meas-events m))) and ae
     for m of-type meas in (part-meas p) ; all one voice
     and cm = t and ba = nil do	; cm = intersect or align w/ beg/end of measure, ba = already made some rests invisible this measure
     (loop 
      with mo = (let ((x (if (meas-div m)
			     (nconc (loop with o = (meas-off m) with d = (- (meas-endoff m) o)
					  for e of-type (rational (0)) in (meas-div m) collect o do (incf o (* e d))) (list (meas-endoff m)))
			     (list (meas-off m) (meas-endoff m)))))
		  (loop for (e n) of-type ((rational 0) (or (rational 0) null)) on x
			if n nconc (loop for i from e below n collect i)
			else collect e))
      and tu = 0			; tu = tuplet
      for e in (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-voice* x) v)) (meas-events m)) and lt = tu ; lt = last tuplet
      do (incf tu (apply #'* (event-tupfrac e)))
      if (restp e) do 
      (if (and (null r) (null r0) s (not (and (integerp lt) (find (event-off e) mo))))
	  (setf (event-voice e) (if sv (cons s v) v)) ; set it and leave it, can't start group yet
	  (if (and (integerp tu) (find (event-endoff e) mo)) ; at end of group--save it
	      (progn (unless ba (prepend r0 r1) (push e r1)) ; r1 to possibly turn invisible
		     (prenconc r0 r) (push e r) (setf r0 nil)) ; r to put on a staff, r0 is remaining ones
	      (push e r0)))
      else if (notep e) do 
      (unless s (setf s (event-staff e))) 
      (let ((ss (event-staff e))) ; decide which staff to stick the rests on
	(if r				; have remaining ones
	    (let ((o1 (event-off (last-element r))) ; o1, o2 offset bounds of r
		  (o2 (event-endoff (first r))))
	      (setf ae (nconc (delete-if (lambda (x) (declare (type noteex x)) (<= (event-endoff x) o1)) ae) ; ae is all notes in span o1 to o2 on all staves (one voice)
			      (loop for x0 on ae0 for x of-type noteex = (first x0) while (< (event-off x) o2) when (> (event-endoff x) o1) collect x finally (setf ae0 x0))))
	      #+debug (check-order ae "DISTR-RESTS-BYCONFL" #'sort-offdur)
	      (flet ((td (s)		; total duration of notes
		       (declare (type (integer 1) s))
		       (multiple-value-bind (gr no) (split-list (remove-if-not (lambda (x) (declare (type noteex x)) (= (event-staff x) s)) ae) #'event-grace)
			 (max (mloop for e of-type noteex in gr maximize (event-graceeffdur e))
			      (loop
			       for (a . b) of-type ((rational 0) . (rational 0))
			       in (merge-linear (mapcar (lambda (x) (declare (type noteex x)) (cons (max (event-off x) o1) (min (event-endoff x) o2))) no)
						(lambda (x y) (declare (type (cons (rational 0) (rational 0)) x y)) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
			       sum (- b a)))))
		     (iv (ts)		; make rests in r1 invisible
		       (when (and (or (eq *grandstaff-hide-rests* :all) (and *grandstaff-hide-rests* (> ts 0)))	; ts > 0 means some conflict w/ notes
				  cm (not ba) r1 (or (null *min-grandstaff-hide-rests-dur*) (>= (- o2 o1) *min-grandstaff-hide-rests-dur*))) ; 4/1/06 r1
			 (mapc (lambda (x) (declare (type restex x)) (setf (event-inv x) t)) r1)
			 (push (cons (cons (event-off (last-element r1)) o2) r1) rl) ; rl = list of ((o1 . o2) . inv-rests)
			 (setf ba t))))	; already made rests inv this measure
		(let ((ts1 nil) (ts2 nil))
		  (if (and (/= s ss) (> (setf ts1 (td s)) (setf ts2 (td ss)))) ; amount of conflict with staves of first/last note--s is staff of last note before e
		      (progn (setf s ss)
			     (mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r)
			     (iv ts2))	; go with staff of last note
		      (progn (mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r)
			     (setf s ss)
			     (iv (or ts1 (td s))))))))
	    (setf s ss)))		; go with staff of first note
      (mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r0) ; set rest of the rests
      (setf r nil r0 nil r1 nil cm nil)) (print-dot)
     finally
     (mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons (or s 1) v) v))) (nconc r0 r))))
   (loop
    with ee 
    do (loop				; find the holes and plug them
	for e in (setf ee (get-holes (merge-linear (mapcan (lambda (m)
							     (declare (type meas m))
							     (loop for y of-type (or noteex restex) in (meas-events m)
								   unless (and (restp y) (event-inv y))
								   collect (cons (event-off y) (event-endoff y))))
							   (part-meas p))
						   (lambda (x y) (declare (type (cons (rational 0) (rational 0)) x y)) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
				     0 lo))
	for m = (loop-return-argmin
		 (event-voice* (first (cdr i))) ; first voice
		 for i of-type (cons (cons (rational 0) (rational 0)) *)
		 in (loop-return-argmins
		     (cdar i) 
		     for i of-type (cons (cons (rational 0) (rational 0)) *)
		     in (loop-return-argmins
			 (caar i)	; earliest one
			 for i of-type (cons (cons (rational 0) (rational 0)) *)
			 in (loop-return-argmins
			     (- (cdar i) (caar i)) ; smallest one
			     for i of-type (cons (cons (rational 0) (rational 0)) *)
			     in (let ((o1 (car e)) (o2 (cdr e)))
				  (declare (type (rational 0) o1 o2))
				  (or (remove-if-not (lambda (x)
						       (declare (type (cons (cons (rational 0) (rational 0)) *) x))
						       (and (<= (caar x) o1) (>= (cdar x) o2))) rl) ; complete fit
				      (remove-if-not (lambda (x)
						       (declare (type (cons (cons (rational 0) (rational 0)) *) x))
						       (and (< (caar x) o2) (> (cdar x) o1))) rl)))))))	; partial fit
	#+debug unless #+debug m #+debug do #+debug (error "Error in DISTR-RESTS-BYCONFL")
	do
	(mapc (lambda (x) (declare (type restex x)) (setf (event-inv x) nil)) (cdr m)) ; turn back to visible
	(setf rl (delete m rl :test #'equal))
	(print-dot))
    while ee)))

(defun distr-rests (parts)
  (case (auto-distr-rests-fun)
    (:rests1 (distr-rests-byconfl parts))
    (otherwise (error "Unknown rest to staves distribution module ~S" *auto-distr-rests-module*))))