[gsharp-cvs] CVS gsharp

[rstrandh]

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv14102

Modified Files:
	drawing.lisp 
Log Message:
Fixed a problem with displaying fractional beams when a beam
group contains elements other than clusters (such as rests).


--- /project/gsharp/cvsroot/gsharp/drawing.lisp	2006/06/26 16:37:43	1.73
+++ /project/gsharp/cvsroot/gsharp/drawing.lisp	2007/01/07 06:05:35	1.74
@@ -629,6 +629,16 @@
 			  (if (< (pitch n1) (pitch n2)) n1 n2))))))
 	  notes))
 
+(defun cluster-p (element)
+  (typep element 'cluster))
+
+(defun map-over-cluster-pairs (fun list)
+  (loop for sublist on list
+	do (when (cluster-p (car sublist))
+	     (let ((second (find-if #'cluster-p (cdr sublist))))
+	       (when second
+		 (funcall fun (car sublist) second))))))
+
 (defun draw-beam-group (pane elements)
   (let ((e (car elements)))
     (when (typep e 'gsharp-buffer::key-signature)
@@ -694,28 +704,29 @@
 		    (loop for beams from (1+ min-nb-beams) to max-nb-beams
 			  for ss from (* 2 min-nb-beams) by 2
 			  for offset from min-nb-beams
-			  do (loop for (e1 e2) on elements
-				   do (when (not (null e2))
-					(cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams))
-					       (setf region 
-						     (region-union region
-								   (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000
-										    (+ (final-absolute-element-xoffset e2) right) 10000))))
-					      ((>= (rbeams e1) beams)
-					       (setf region
-						     (region-union region 
-								   (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000
-										    (+ (final-absolute-element-xoffset e1) right (score-pane:staff-step 2)) 10000))))
-					      ((>= (lbeams e2) beams)
-					       (setf region
-						     (region-union region 
-								   (make-rectangle* (+ (final-absolute-element-xoffset e2) right (score-pane:staff-step -2)) -10000
-										    (+ (final-absolute-element-xoffset e2) right) 10000))))
-					      (t nil))))
-			     (with-drawing-options (pane :clipping-region region)
-			       (score-pane:draw-beam pane
-						     (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset)
-						     (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset))))))
+			  do (map-over-cluster-pairs
+			      (lambda (e1 e2)
+				(cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams))
+				       (setf region 
+					     (region-union region
+							   (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000
+									    (+ (final-absolute-element-xoffset e2) right) 10000))))
+				      ((>= (rbeams e1) beams)
+				       (setf region
+					     (region-union region 
+							   (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000
+									    (+ (final-absolute-element-xoffset e1) right (score-pane:staff-step 2)) 10000))))
+				      ((>= (lbeams e2) beams)
+				       (setf region
+					     (region-union region 
+							   (make-rectangle* (+ (final-absolute-element-xoffset e2) right (score-pane:staff-step -2)) -10000
+									    (+ (final-absolute-element-xoffset e2) right) 10000))))
+				      (t nil)))
+			      elements)
+			    (with-drawing-options (pane :clipping-region region)
+			      (score-pane:draw-beam pane
+						    (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset)
+						    (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset))))))
 		(score-pane:with-notehead-left-offsets (left down)
 		  (declare (ignore down))
 		  (loop repeat min-nb-beams
@@ -728,24 +739,25 @@
 		    (loop for beams from (1+ min-nb-beams) to max-nb-beams
 			  for ss from (* 2 min-nb-beams) by 2
 			  for offset from min-nb-beams
-			  do (loop for (e1 e2) on elements
-				   do (when (not (null e2))
-					(cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams))
-					       (setf region 
-						     (region-union region
-								   (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000
-										    (+ (final-absolute-element-xoffset e2) left) 10000))))
-					      ((>= (rbeams e1) beams)
-					       (setf region
-						     (region-union region 
-								   (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000
-										    (+ (final-absolute-element-xoffset e1) left (score-pane:staff-step 2)) 10000))))
-					      ((>= (lbeams e2) beams)
-					       (setf region
-						     (region-union region 
-								   (make-rectangle* (+ (final-absolute-element-xoffset e2) left (score-pane:staff-step -2)) -10000
-										    (+ (final-absolute-element-xoffset e2) left) 10000))))
-					      (t nil))))
+			  do (map-over-cluster-pairs
+			      (lambda (e1 e2)
+				(cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams))
+				       (setf region 
+					     (region-union region
+							   (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000
+									    (+ (final-absolute-element-xoffset e2) left) 10000))))
+				      ((>= (rbeams e1) beams)
+				       (setf region
+					     (region-union region 
+							   (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000
+									    (+ (final-absolute-element-xoffset e1) left (score-pane:staff-step 2)) 10000))))
+				      ((>= (lbeams e2) beams)
+				       (setf region
+					     (region-union region 
+							   (make-rectangle* (+ (final-absolute-element-xoffset e2) left (score-pane:staff-step -2)) -10000
+									    (+ (final-absolute-element-xoffset e2) left) 10000))))
+				      (t nil)))
+			      elements)
 			     (with-drawing-options (pane :clipping-region region)
 			       (score-pane:draw-beam pane
 						     (+ (final-absolute-element-xoffset (car elements)) left) (+ ss1 ss) (- offset1 offset)