comparison tools/gsharp-output.lisp @ 202:3e7b33ae3a0d

Gsharp preview 'fixes'

committer: David Lewis <[e-mail]>

   notehead (beams 0) (dots 0) (tied-p nil))
 
 ;;;;;;;;;;;;;;;;;;;;;
 ;; Top-level methods
 
-(defparameter *foo* nil)
-
 (defun write-gsharp-eps (composition pathname)
   ;; write a score eps from a composition. Most of this can be copied
   ;; straight (this is copied already from CSR's code)
   ;; Boilerplate stuff:
-  (let* ((frame (clim:make-application-frame 'gsharp:gsharp))
+  (let* ((frame (clim:make-application-frame 'gsharp::gsharp))
          (clim:*application-frame* frame)
          (esa:*esa-instance* frame))
       (clim:adopt-frame (clim:find-frame-manager :server-path '(:null)) frame)
       (clim:execute-frame-command frame '(gsharp::com-new-buffer))
       ;; Now generate the buffer
       (make-objects-for-gsharp-buffer composition (car (esa:buffers frame)))
       ;; (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
       ;; Refresh and process
       (setf (gsharp::modified-p (car (esa:buffers frame))) t)
       (gsharp::recompute-measures (car (esa:buffers frame)))
-      (setf *foo* (car (esa:buffers frame)))
       ;; Print
       (clim:execute-frame-command
        frame `(gsharp::com-print-buffer-to-file ,pathname))
       (car (esa:buffers frame))))
+
+(defun gsharp-change-size-but-keep-bounding-box (left-margin right-edge buffer)
+  (declare (ignorable buffer))
+  (setf gsharp-buffer::*default-left-margin* left-margin
+        (gsharp-buffer::left-margin buffer) left-margin
+        gsharp-buffer::*default-right-edge* right-edge
+        (gsharp-buffer::right-edge buffer) right-edge
+        gsharp::*scale* (/ (+ left-margin right-edge) 900)
+        gsharp::*top-margin* (/ 80 gsharp::*scale*)))
+
+(defun prepare-gsharp-for-single-system-stuff (buffer)
+  (gsharp-change-size-but-keep-bounding-box 5 1100 buffer)
+  (setf gsharp-measure::*staves-per-page* (length (gsharp::staves buffer))))
+
+(defun write-gsharp-ps-single-system (composition pathname)
+  ;; write a score eps from a composition. Most of this can be copied
+  ;; straight (this is copied already from CSR's code)
+  ;; Boilerplate stuff:
+  (let* ((frame (clim:make-application-frame 'gsharp::gsharp))
+         (clim:*application-frame* frame)
+         (esa:*esa-instance* frame))
+      (clim:adopt-frame (clim:find-frame-manager :server-path '(:null)) frame)
+      (clim:execute-frame-command frame '(gsharp::com-new-buffer))
+      ;; Now generate the buffer
+      (make-objects-for-gsharp-buffer composition (car (esa:buffers frame)))
+      ;; (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
+      ;; Refresh and process
+      (setf (gsharp::modified-p (car (esa:buffers frame))) t)
+      (gsharp::recompute-measures (car (esa:buffers frame)))
+      (prepare-gsharp-for-single-system-stuff (car (esa:buffers frame)))
+      (gsharp::recompute-measures (car (esa:buffers frame)))
+      ;; Print
+      (clim:execute-frame-command
+       frame `(gsharp::com-print-buffer-to-file ,pathname))
+      (car (esa:buffers frame))))
+
+(defun gsharp-preview (composition)
+  ;; see above for origin of this code
+  (let* ((frame (clim:make-application-frame 'gsharp::gsharp-minimal))
+         (clim:*application-frame* frame)
+         (esa:*esa-instance* frame))
+    (clim:adopt-frame (clim:find-frame-manager :server-path '(:clx)) frame)
+    (clim:execute-frame-command frame '(gsharp::com-new-buffer))
+    ;; Now generate the buffer
+    (make-objects-for-gsharp-buffer composition (car (esa:buffers frame)))
+    ;; (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
+    ;; make views, cursors, input states, etc.
+    (let ((view (make-instance 'gsharp::orchestra-view
+                               :buffer (car (esa:buffers frame))
+                               :cursor (gsharp::make-initial-cursor 
+					(car (esa:buffers frame))))))
+      (push view (gsharp::views gsharp::*application-frame*))
+      (setf (gsharp::view (car (gsharp::windows gsharp::*application-frame*))) view
+            (gsharp::input-state gsharp::*application-frame*) (gsharp::make-input-state)))
+    ;; Refresh and process
+    (setf (gsharp::modified-p (car (esa:buffers frame))) t)
+    (gsharp::recompute-measures (car (esa:buffers frame)))
+    (gsharp::update-page-numbers frame)
+    #+nil
+    (clim:redisplay-frame-panes frame)
+    (clim:run-frame-top-level frame)))
+
+(defparameter *composition-event-maps* (make-hash-table :test 'eq))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; Big `walking through data structures' type functions
 

   gsharp-layer-string, and from this, the connections are
   made. gsharp-staff-string defaults to calling gsharp-layer-string,
   so in most cases there will be a single staff for each layer. Events
   are added, and then staves are sorted using staff<. A proper layout
   object would be another way of doing this."
-  (let ((layer-names (make-hash-table :test #'equal))
-	(layer-events (make-hash-table))
-	(layer-staves (make-hash-table))
-	(staff-names (make-hash-table :test #'equal))
-	(staff-name)(staff)(layer-name)(layer)
-	(segment))
-    (sequence::dosequence (event composition)
-      ;; can't do percussion parts yet:
-      (when (pitchedp event)
-	(setf layer-name (gsharp-layer-string event)
-	      layer (gethash layer-name layer-names)
-	      staff-name (gsharp-staff-string event)
-	      staff (gethash staff-name staff-names))
-	(if staff
-	    ;; this looks a little cryptic, but we're keeping note of
-	    ;; whether the mean pitch is above C for clef guessing.
-	    (setf (third staff) (+ (third staff) 1)
-		  (second staff) (+ (second staff) (min (floor (midi-pitch-number event) 60) 1)))
-	    (setf staff (list (gsharp::make-fiveline-staff :name staff-name)
-			      (min (floor (midi-pitch-number event) 60)
-				   1)
-			      1)
-		  (gsharp::buffer (car staff)) buffer
-		  (gethash staff-name staff-names) staff))
-	(if layer
-	    (progn
-	      (unless (find (first staff) (gethash layer layer-staves))
-		(push (first staff) (gethash layer layer-staves)))
-	      (push event (gethash layer layer-events)))
-	    (if segment
-		(setf layer (gsharp::make-layer (list (first staff))
-						:body (gsharp::make-slice :bars nil)
-						:name layer-name
-						:segment segment)
-		      (gsharp::layers segment) (cons layer (gsharp::layers segment))
-		      (gethash layer-name layer-names) layer
-		      (gethash layer layer-staves) (list staff)
-		      (gethash layer layer-events) (list event))
-		(setf layer (gsharp::make-layer (list (first staff))
-						:body (gsharp::make-slice :bars nil)
-						:name layer-name)
-		      segment (make-instance 'gsharp::segment
-					     :buffer buffer
-					     :layers (list layer))
-		      (gsharp-buffer:segment layer) segment
-		      (gethash layer-name layer-names) layer
-		      (gethash layer layer-staves) (list (first staff))
-		      (gethash layer layer-events) (list event))))))
-    (maphash #'(lambda (key val)
-		 (declare (ignore key))
-		 (unless (>= (second val) (/ (third val) 2))
-		   (setf *foo* (first val))
-		   (setf (gsharp::clef (first val)) (gsharp::make-clef :bass))))
-	     staff-names)
+  (multiple-value-bind (layer-events layer-staves)
+      (%gather-objects-for-gsharp-output composition buffer)
+    ;; Add events/notes/clusters
     (maphash #'(lambda (key events)
 		 (add-music-to-layer key
 				     (reverse events)
 				     (gethash key layer-staves)
 				     composition
 				     (handler-bind ((insufficient-information
 						     #'(lambda (c)
 							 (declare (ignore c))
 							 (invoke-restart 'guess))))
 				       (get-applicable-key-signatures composition composition))))
-	     layer-events)
-    (setf (gsharp::segments buffer) (list segment)
-	  (gsharp::staves buffer) nil)
-    (let ((staves))
-      (maphash #'(lambda (key val)
-		   (declare (ignore key))
-		   (push (car val) staves))
+             layer-events)
+    buffer))
+
+(defun %gather-objects-for-gsharp-output (composition buffer)
+  (let ((layer-names (make-hash-table :test #'equal))
+        (layer-events (make-hash-table))
+        (layer-staves (make-hash-table))
+        (staff-names (make-hash-table :test #'equal))
+        (staff-name) (staff) (layer-name) (layer) (staves)
+        (segment))
+    (sequence::dosequence (event composition)
+      ;; can't do percussion parts yet:
+      (when (pitchedp event)
+        (setf layer-name (gsharp-layer-string event)
+              layer (gethash layer-name layer-names)
+              staff-name (gsharp-staff-string event)
+              staff (gethash staff-name staff-names))
+	(unless staff
+	  (setf staff (list (%new-gsharp-staff-for-amuse staff-name buffer)
+			    0 0)
+		(gethash staff-name staff-names) staff))
+	;; Keeping note of whether the mean pitch is above C for clef
+	;; guessing.
+	(setf (third staff) (+ (third staff) 1)
+	      (second staff) (+ (second staff)
+				(min (floor (midi-pitch-number event) 60) 1)))
+	;; Check if layer has happened before, if not make it
+	(unless layer
+	  (setf layer (%create-and-record-layer layer-name (first staff)
+					       segment buffer layer-names
+					       layer-staves layer-events)
+		segment (gsharp::segment layer)))
+	;; Associate new event with layer
+	(setf layer-events 
+	      (%add-event-to-layer-hash event (first staff)
+				       layer layer-events layer-staves))))
+    ;; Guess clefs for staves: bass if most pitches are below middle
+    ;; C, otherwise treble. (yes, I know this is stupid)
+    (maphash #'(lambda (key val)
+                 (declare (ignore key))
+                 (unless (>= (second val) (/ (third val) 2))
+                   (setf (gsharp::clef (first val)) (gsharp::make-clef :bass))))
+             staff-names)
+    ;; gather and sort staves
+    (maphash #'(lambda (key val)
+		 (declare (ignore key))
+		 (push (car val) staves))
 	     staff-names)
-      (setf staves (sort staves #'stave<))
-      (setf (gsharp::staves buffer) staves)
-      buffer)))
+    (setf staves (sort staves #'stave<)
+	  (gsharp::staves buffer) staves)
+    (values layer-events layer-staves)))
+
+(defun %new-gsharp-staff-for-amuse (staff-name buffer)
+  (let ((staff (gsharp::make-fiveline-staff :name staff-name)))
+    (setf (gsharp::buffer staff) buffer)
+    staff))
+
+(defun %add-event-to-layer-hash (event staff layer layer-events layer-staves)
+;;  (unless (find staff (gethash layer layer-staves))
+  (unless (member staff (gethash layer layer-staves))
+    (push staff (gethash layer layer-staves)))
+  (push event (gethash layer layer-events))
+  layer-events)
+
+(defun %create-and-record-layer (name staff segment buffer
+				 layer-names layer-staves layer-events)
+  ;; create fresh layer called name and add to all necessary objects
+  (let ((layer (gsharp::make-layer (list staff)
+				   :body (gsharp::make-slice :bars nil)
+				   :name name
+				   :segment segment)))
+    (if segment
+	(setf (gsharp::layers segment) 
+	      (cons layer (gsharp::layers segment)))
+	(setf segment (make-instance 'gsharp::segment
+				     :buffer buffer
+				     :layers (list layer))
+	      (gsharp::segment layer) segment
+	      (gsharp::segments buffer) (list segment)))
+    (setf (gethash name layer-names) layer
+	  (gethash layer layer-staves) nil
+	  (gethash layer layer-events) nil)
+    layer))
+
 (defgeneric stave< (staff1 staff2)
   (:method (s1 s2)
     (let* ((clefs '(:treble :bass))
 	   (c1 (gsharp::clef s1))
 	   (c2 (gsharp::clef s2))

 		       (>= beat-time (second bars)))
 	    (push (reverse current) starts)
 	    (setf current nil
 		  bars (cdr bars)))
 	  (push beat-time current))))))
-(defun add-music-to-layer (layer events staves composition key-sigs)
-  "Creating all the musical objects for the gsharp staves in the
-provided layer"
+
+(defgeneric add-music-to-layer (layer events staves composition key-sigs)
+  (:documentation "Creating all the musical objects for the gsharp staves in the
+provided layer"))
+;; change this into some sort of quantize-please mixin? or switch? or something
+(defmethod add-music-to-layer (layer events staves (composition amuse-midi::unquantized-composition) key-sigs)
   (let* ((bar-moments (bar-starts-2 composition))
 	 (beat-moments (or (beat-starts-2 bar-moments composition)
-			   bar-moments))
+			   (mapcar #'list bar-moments)))
 	 (body (gsharp::body layer))
 	 (bar-no 0)
 	 (ons) (position) (clusters) (bar))
     ;; this is a cheat to guess timing rounding (quantisation) based
     ;; on onset times - only affects midi-like data where onsets are
     ;; already rounded, but durations are not (as in TC's fantasia
     ;; midi files....)
-    (setf *rounding-factor* (max (guess-rounding-factor events)
+    (setf *rounding-factor* (max (guess-rounding-factor-smart events)
                                  1/8))
     ;; First create a list of change-points for when events are
     ;; sounding, of the format (time event event event) (time event))
     (dolist (event events)
       (setf ons (add-on-off-pair event ons)))

     ;; Finally, one problem here is that, in midi, there is often a
     ;; gap or overlap between consecutive notes or chords. Since
     ;; rounding happens, but there is no check for bar length here or
     ;; within g-sharp, this should verify that everything makes
     ;; sense. At the moment, it just removes short rests...
-    (setf ons (check-ons ons bar-moments))
+    (setf ons (check-ons-2 ons bar-moments))
     ;; Now create the bars and the gsharp clusters
     (when key-sigs
       (dolist (staff staves)
 	(setf (gsharp::keysig staff)
 	      (make-gsharp-key-signature (car key-sigs) staff))))
     (do ((old-ons nil ons)
          (ons ons (cdr ons)))
-        ((null (cdr ons)))
+        ((null (car ons)))
       (when (member (caar ons) bar-moments)
         ;; We're at the beginning of a bar.
         (when bar (check-beams bar))
         (setf bar (gsharp::make-melody-bar))
         (gsharp::add-bar bar body bar-no)

       ;; time signature (for example, a note of a tactus beat + a
       ;; quaver in 6/8 will be rendered as a minim this way) - that's
       ;; why I've taken as much of the metrical logic out and put it
       ;; above if there are other straightforward rules, they should,
       ;; I think go there.
-      (if (cdar ons)
-          (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons))
-								(car (car ons)))))
-          (setf clusters (make-gsharp-rests-with-duration (- (car (second ons))
-							     (car (car ons)))
-							  layer)))
+      ;; NB now incorporating JF fix (not via version control)
+      (if (second ons)
+	  (if (cdar ons)
+	      (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons))
+								    (car (car ons)))))
+	      (setf clusters (make-gsharp-rests-with-duration (- (car (second ons))
+								 (car (car ons)))
+							      layer)))
+	  (if (cdar ons)
+	      (setf clusters (make-gsharp-clusters-with-duration (duration (cadar ons))))
+	      (setf clusters (make-gsharp-rests-with-duration (- (timepoint 
+								  (cut-off composition))
+								 (caar ons))
+							      layer))))
       (let ((now (caar ons)) (first-p t) (pitches))
         (do ((clusters clusters (cdr clusters)))
             ((null clusters))
           (when (member now (car beat-moments))
             (setf (gsharp::lbeams (car clusters)) 0))

                                                :staff (staff-for-note (car pitch) staves)
                                                :tie-right (if (or (cdr clusters)
                                                                   (member (car pitch) (second ons)))
                                                               t
                                                               nil)
-                                               :tie-left (if first-p
-                                                             (member (car pitch) (first old-ons))
-                                                             t)))))
+                                               :tie-left (if (or first-p
+                                                                 (member (car pitch) (first old-ons)))
+                                                             t
+                                                             nil)))))
           (incf now (* (gsharp::duration (car clusters)) 4))
           (setf first-p nil)
           (incf position)))
       (when (and (cdr bar-moments)
                  (= (car (second ons))
                     (second bar-moments)))
         (setf bar-moments (cdr bar-moments)
               beat-moments (cdr beat-moments))))))
+
+(defclass amuse-gsharp-note (gsharp::note)
+  ((composition :initarg :composition
+		:accessor composition)
+   (event :initarg :event
+	  :accessor event)
+   (groups :initarg :groups
+	  :accessor groups)))
+
+(defun make-amuse-gsharp-note (event staves composition 
+			       &key tie-right tie-left groups)
+  (destructuring-bind (pitch accidental)
+      (pitch-for-gsharp event composition)
+    (let ((note (make-instance 'amuse-gsharp-note 
+			       :pitch pitch
+			       :accidentals accidental
+			       :staff (staff-for-note event staves)
+			       :tie-right tie-right
+			       :tie-left tie-left
+			       :composition composition
+			       :event event
+			       :groups groups))
+	  (event-map (get-event-map composition)))
+      (setf (gethash event event-map) note)
+      note)))
+
+(defun get-event-map (composition)
+  (unless (gethash composition *composition-event-maps*)
+    (setf (gethash composition *composition-event-maps*)
+	  (make-hash-table :test 'eq)))
+  (gethash composition *composition-event-maps*))
+
+(defun get-gsharp-note (event composition)
+  (gethash event (get-event-map composition)))
+
+(defmethod add-music-to-layer (layer events staves composition key-sigs)
+  ;; no beaming yet
+  (let* ((scale (duration (crotchet composition)))
+	 (times (loop for event in events
+		   collect (timepoint event)
+		   collect (timepoint (cut-off event))))
+	 (event-array)
+	 (bar-no 0) (slice (gsharp::body layer)) (bar)
+	 (position 0) (bar-starts) (clusters))
+    (do* ((bar-period (current-bar (make-moment 0) composition)
+		      (current-bar (cut-off bar-period) composition))
+	  (bar-start (when bar-period (timepoint bar-period))
+		     (when bar-period (timepoint bar-period))))
+	 ((time>= (cut-off bar-period) (cut-off composition))
+	  (setf bar-starts (reverse bar-starts)))
+      (push bar-start times)
+      (push bar-start bar-starts))
+    (setf times (sort (remove-duplicates times) #'<)
+	  event-array (make-array (list-length times) :initial-element nil))
+    ;; Create an array of which rhythmic clusters each event belongs
+    ;; to (notational clusters come later)
+    (loop for time in times
+       for i from 0
+       do (loop for event in events
+	     while (<= (timepoint event) time)
+	     when (> (timepoint (cut-off event)) time)
+	     do (push event (aref event-array i))))
+    (when (and key-sigs (= (timepoint (first key-sigs)) 0))
+      (mapcar #'(lambda (x) (set-staff-key-signature (first key-sigs) x))
+	      staves)
+      (setf key-sigs (cdr key-sigs)))
+    (do ((times times (cdr times))
+	 (i 0 (1+ i)))
+	((not times))
+      (when (and bar-starts (<= (first bar-starts) 
+				(first times)))
+	(setf bar (gsharp::make-melody-bar))
+	(gsharp::add-bar bar slice bar-no)
+	(incf bar-no)
+	(setf position 0)
+	(setf bar-starts (cdr bar-starts)))
+      (if (aref event-array i)
+	  (setf clusters (make-gsharp-clusters-with-exact-duration
+			  (/ (- (or (second times)
+				    (timepoint (cut-off composition)))
+				(first times))
+			     scale)))
+	  (setf clusters (make-gsharp-rests-with-exact-duration
+			  (/ (- (or (second times)
+				    (timepoint (cut-off composition)))
+				(first times))
+			     scale)
+			  layer)))
+      ;; FIXME: This has possible problem cases for key-sig changes
+      ;; mid-note and for multi-staff signatures. Fix this when the
+      ;; AMUSE representation is a bit richer.
+      (when (and key-sigs (<= (timepoint (first key-sigs))
+			      (first times)))
+	(gsharp::add-element (make-gsharp-key-signature (car key-sigs)
+							(gsharp::staff bar))
+		     bar position)
+	(incf position)
+	(setf key-sigs (cdr key-sigs)))
+      (do* ((clusters clusters (cdr clusters))
+	    (cluster (car clusters) (car clusters))
+	    (firstp t nil))
+	   ((not clusters))
+	(gsharp::add-element cluster bar position)
+	(incf position)
+	;; There will be trouble with same pitch in same layer,
+	;; but that's a gsharp bug, not an amuse one
+	(dolist (event (aref event-array i))
+	  (gsharp::add-note
+	   cluster
+	   (make-amuse-gsharp-note event staves composition 
+				   :tie-right (or (cdr clusters)
+						  (and (< (1+ i) (length event-array))
+						       (member event (aref event-array (1+ i)))))
+				   :tie-left (or (not firstp)
+						 (and (> i 0)
+						      (member event (aref event-array (1- i))))))))))))
 
 (defun staff-for-note (event staves)
   (find-if #'(lambda (x) (string= (gsharp::name x) (gsharp-staff-string event)))
 	   staves))
 

          (setf (gsharp::rbeams mid) 0))
         ((< (gsharp::rbeams left)
             (gsharp::lbeams right))
          (setf (gsharp::lbeams mid) (gsharp::rbeams left)))
         (t (setf (gsharp::rbeams mid) (gsharp::lbeams right)))))))
+
+(defun set-staff-key-signature (key-sig staff)
+  (setf (gsharp::keysig staff)
+	(make-gsharp-key-signature key-sig staff)))
 
 (defgeneric make-gsharp-key-signature (key-signature object))
 (defmethod make-gsharp-key-signature ((key-signature standard-key-signature) (layer gsharp-buffer::layer))
   (let ((alterations (make-array 7 :initial-element :natural))
         (order-of-sharps #(3 0 4 1 5 2 6))

                                             (- (slot-value e 'amuse::number) 21)))) into result
           finally (return (sort result #'sorter :key #'car)))))
 
 ;; Time 
 
+(defun make-gsharp-clusters-with-exact-duration (duration)
+  ;; at least for now
+  (make-gsharp-clusters-with-duration duration))
 (defun make-gsharp-clusters-with-duration (duration)
   "Returns a list of cluster(s) whose total duration is equal to
   duration (which is given in crotchets)"
   (let ((new-durations (gsharp-durations-from-beats duration)))
     (loop for new-duration in new-durations
          collect (gsharp::make-cluster :notehead (gsharp-duration-notehead new-duration)
                                        :lbeams (gsharp-duration-beams new-duration)
                                        :rbeams (gsharp-duration-beams new-duration)
                                        :dots  (gsharp-duration-dots new-duration)))))
 
+(defun make-gsharp-rests-with-exact-duration (duration layer)
+  ;; at least for now
+  (make-gsharp-rests-with-duration duration layer))
 (defun make-gsharp-rests-with-duration (duration layer)
   "Returns a list of rest(s) whose total duration is equal to
   duration (which is given in crotchets)"
   (let ((new-durations (gsharp-durations-from-beats duration)))
     (loop for new-duration in new-durations
-       collect(gsharp::make-rest (car (gsharp::staves layer))
+       collect (gsharp::make-rest (car (gsharp::staves layer))
                                  :notehead (gsharp-duration-notehead new-duration)
                                  :lbeams (gsharp-duration-beams new-duration)
                                  :rbeams (gsharp-duration-beams new-duration)
                                  :dots  (gsharp-duration-dots new-duration)))))
 

 
 (defun add-on-off-pair (event data)
   "For walking through an ordered event sequence and building up a
 list of changes to sounding pitches, this function takes an event and
 adds the time for which it sounds to the structure."
-  (let ((copied-data)
-        (on (* (round
+  (let* ((copied-data) (rounding (/ *rounding-factor* 2))
+	 (on (* (timepoint event)
+		(duration (crotchet event)))
+	 #+nil (* (round
                 (* (timepoint event)
                    (duration (crotchet event)))
-                *rounding-factor*) *rounding-factor*))
-        (off (* (round
-                 (* (timepoint (cut-off event))
-                    (duration (crotchet event)))
-                 *rounding-factor*) *rounding-factor*)))
+                rounding) rounding))
+	 (off (* (round
+		  (* (timepoint (cut-off event))
+		     (duration (crotchet event)))
+		  rounding) rounding)))
     (do ((data data (cdr data)))
         ((null data) (reverse (cons (list off)
                                     (cons (list on event)
                                           copied-data))))
       (cond

                 notes (cdar ons))
           (dolist (note (cdar ons))
             (unless (member note notes)
               (push note notes)))))))
 
+(defun check-ons-2 (ons bar-starts)
+  "looks for small rests such as might be created by midi performance
+of tenuto lines"
+  (let ((best-time) (found-bar) (new-ons))
+    (do* ((ons ons (cdr ons))
+	  (on1 (first ons) (first ons))
+	  (on2 (second ons) (second ons))
+	  (query nil nil))
+	 ((null on2) (reverse new-ons))
+      (unless found-bar
+	(cond
+	  ((member (first on1) bar-starts)
+	   (setf found-bar t
+		 best-time (first on1)))
+	  ((or (not best-time)
+	       (better-timep (first on1) best-time)) ;; this ought to know about tactus
+	   (setf best-time (first on1)))))
+      (when (>= (- (first on2) (first on1))
+		*rounding-factor*)
+	(push (cons best-time (cdr on1)) new-ons)
+	(setf best-time nil
+	      found-bar nil)))))
+       
+(defun better-timep (t1 t2)
+  (< (or (granularity t1 4)
+	 (granularity (/ (round t1 1/16) 16) 4))
+     (or (granularity t2 4)
+	 (granularity (/ (round t2 1/16) 16) 4))))
+
+(defun granularity (n &optional (max 16))
+  (loop for i from 1 to max
+     when (= (rem n (expt 2 (- i))) 0)
+       do (return-from granularity i)))
+
 #+nil
 
 (defun check-ons (ons)
   "looks for small rests such as might be created by midi performance
 of tenuto lines"

 onsets"
   (let ((times (map 'list #'(lambda (x)
                               (denominator (* (timepoint x)
                                               (duration (crotchet x)))))
                     events)))
+
     (/ 1 (apply #'lcm times))))