[gsharp-cvs] CVS update: gsharp/drawing.lisp

[Robert Strandh]

Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv6376

Modified Files:
	drawing.lisp 
Log Message:
Be more precise when computing beam groups.

It is now possible to have a rest or an empty cluster in the middle
of a beam group. 

Date: Sat Nov 19 22:59:26 2005
Author: rstrandh

Index: gsharp/drawing.lisp
diff -u gsharp/drawing.lisp:1.27 gsharp/drawing.lisp:1.28
--- gsharp/drawing.lisp:1.27	Sat Nov 19 06:16:28 2005
+++ gsharp/drawing.lisp	Sat Nov 19 22:59:25 2005
@@ -214,8 +214,9 @@
 	    (bot-note (bot-note (notes element))))
 	(setf (top-note-pos element) (note-position top-note)
 	      (bot-note-pos element) (note-position bot-note)))
-      (setf (top-note-pos element) 4
-	    (bot-note-pos element) 4)))
+;;      (setf (top-note-pos element) 4
+;;	    (bot-note-pos element) 4)
+      ))
 
 ;;; Compute and store several important pieces of information
 ;;; about an element:
@@ -304,13 +305,24 @@
 	    (incf start-time (duration element)))
 	  (elements bar))))
 
+;;; Return true if and only if the element is a non-empty cluster
+(defun non-empty-custer-p (element)
+  (and (typep element 'cluster)
+       (not (null (notes element)))))
+
 ;;; Compute and store the final stem directions of all the elements of
 ;;; a beam group with at least two elements in it.
 (defun compute-final-stem-directions (elements)
   (let ((stem-direction (if (not (eq (stem-direction (car elements)) :auto))
 			    (stem-direction (car elements))
-			    (let ((top-note-pos (reduce #'max elements :key #'top-note-pos))
-				  (bot-note-pos (reduce #'min elements :key #'bot-note-pos)))
+			    (let ((top-note-pos
+				   (loop for element in elements
+					 when (non-empty-custer-p element)
+					 maximize (top-note-pos element)))
+				  (bot-note-pos
+				   (loop for element in elements
+					 when (non-empty-custer-p element)
+					 minimize (top-note-pos element))))
 			      (if (>= (- top-note-pos 4) (- 4 bot-note-pos)) :down :up)))))
     (loop for element in elements
 	  do (setf (final-stem-direction element) stem-direction))))
@@ -359,8 +371,9 @@
 	  (draw-element pane element (final-absolute-element-xoffset element))))
       (let* ((stem-direction (final-stem-direction (car elements)))
 	     (dominating-notes
-	      (mapcar (lambda (e) (dominating-note (notes e) stem-direction))
-		      elements))
+	      (loop for element in elements
+		    when (non-empty-custer-p element)
+		    collect (dominating-note (notes element) stem-direction)))
 	     (dominating-staff
 	      (staff (dominating-note dominating-notes stem-direction)))
 	     (positions (mapcar (lambda (n)
@@ -408,17 +421,35 @@
   (draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+))
 
 ;;; Given a list of the elements of a bar, return a list of beam
-;;; groups, where each beam group is a list of elements that are
-;;; beamed together
+;;; groups.  A beam group is defined to be either a singleton list or
+;;; a list with more than one element.  In the case of a singleton,
+;;; the element is either a non-cluster, an empty cluster, a cluster
+;;; that does not beam to the right, or a cluster that does beam to
+;;; the right, but either it is the last cluster in the bar, or the
+;;; first following cluster in the bar does not beam to the left.  In
+;;; the case of a list with more than one element, the first element
+;;; is a cluster that beams to the right, the last element is a
+;;; cluster that beams to the left, and all other clusters in the list
+;;; beam both to the left and to the right.  Notice that in the last
+;;; case, elements other than the first and the last can be
+;;; non-clusters, or empty clusters.
 (defun beam-groups (elements)
   (let ((group '()))
-    (loop while (not (null elements)) do
-	  (setf group '())
-	  (push (pop elements) group)
-	  (loop while (and (not (null elements))
-			   (> (rbeams (car group)) 0)
-			   (> (lbeams (car elements)) 0))
-		do (push (pop elements) group))
+    (loop until (null elements) do
+	  (setf group (list (car elements))
+		elements (cdr elements))
+	  (when (and (non-empty-custer-p (car group))
+		     (plusp (rbeams (car group))))
+	    (loop while (and (not (null elements))
+			     (or (not (typep (car elements) 'cluster))
+				 (null (notes (car elements)))
+				 (plusp (lbeams (car elements)))))
+		  do (push (pop elements) group)
+		  until (and (non-empty-custer-p (car group))
+			     (zerop (rbeams (car group)))))
+	    ;; pop off trailing unbeamable objects
+	    (loop until (non-empty-custer-p (car group))
+		  do (push (pop group) elements)))
 	  collect (nreverse group))))
 
 (defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor)