[gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/score-pane.lisp

Robert Strandh rstrandh at common-lisp.net
Sun Aug 7 23:18:07 UTC 2005


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

Modified Files:
	gui.lisp score-pane.lisp 
Log Message:
More modifications to allow incremental redisplay.  There is still a
problem with beam drawing which has to be converted to use the correct
superclass. 


Date: Mon Aug  8 01:18:03 2005
Author: rstrandh

Index: gsharp/gui.lisp
diff -u gsharp/gui.lisp:1.22 gsharp/gui.lisp:1.23
--- gsharp/gui.lisp:1.22	Tue Aug  2 02:34:41 2005
+++ gsharp/gui.lisp	Mon Aug  8 01:18:02 2005
@@ -26,7 +26,7 @@
    (score (let ((win (make-pane 'score-pane:score-pane
 				:width 400 :height 500
 				:name "score"
-;;				:display-time :no-clear
+				:display-time :no-clear
 				:display-function 'display-score
 				:command-table 'total-melody-table)))
 	    (setf (windows *application-frame*) (list win))


Index: gsharp/score-pane.lisp
diff -u gsharp/score-pane.lisp:1.9 gsharp/score-pane.lisp:1.10
--- gsharp/score-pane.lisp:1.9	Tue Aug  2 02:34:41 2005
+++ gsharp/score-pane.lisp	Mon Aug  8 01:18:02 2005
@@ -50,12 +50,7 @@
 ;;;
 ;;; output recording
 
-;;; we should not have to inherit from standard-boudning-rectangle,
-;;; but the implementation of incremental redisplay in McCLIM assumes
-;;; that this is the case for all output records participating in
-;;; incremental redisplay. 
-
-(defclass score-output-record (displayed-output-record standard-bounding-rectangle)
+(defclass score-output-record (displayed-output-record)
   ((parent :initarg :parent :initform nil :accessor output-record-parent)
    (x :initarg :x1 :initarg :x-position)
    (y :initarg :y1 :initarg :y-position)
@@ -108,34 +103,45 @@
   (with-bounding-rectangle* (x1 y1 x2 y2) record
     (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2))))
 
-;;;;;;;;;;;;;;;;;; pixmap output record
-
-(defclass pixmap-output-record (score-output-record)
-  ((pixmap :initarg :pixmap)))
-
-(defmethod replay-output-record ((record pixmap-output-record) stream
-				 &optional (region +everywhere+)
-				 (x-offset 0) (y-offset 0))
-  (declare (ignore x-offset y-offset region))
-  (multiple-value-bind (x y) (output-record-position record)
-    (with-slots (pixmap) record
-      (let ((medium (sheet-medium stream)))
-	(copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap)
-			  medium x y)))))
+;;;;;;;;;;;;;;;;;; pixmap drawing
 
-(defun make-pixmap-record (class medium x1 y1 x2 y2 pixmap)
-  (multiple-value-bind (x1 y1)
-      (transform-position (medium-transformation medium) x1 y1)
-    (multiple-value-bind (x2 y2)
-	(transform-position (medium-transformation medium) x2 y2)
-      (make-instance class :x1 x1 :x2 x2 :y1 y1 :y2 y2 :pixmap pixmap))))
-
-(defun add-new-pixmap-record (class stream pixmap x y)
-  (let ((width (pixmap-width pixmap))
-	(height (pixmap-height pixmap)))
-    (stream-add-output-record
-     stream (make-pixmap-record class (sheet-medium stream)
-				x y (+ x width) (+ y height) pixmap))))
+(climi::def-grecording draw-pixmap (() pixmap pm-x pm-y) ()
+  (climi::with-transformed-position ((medium-transformation medium) pm-x pm-y)
+    (setf (slot-value climi::graphic 'pm-x) pm-x
+	  (slot-value climi::graphic 'pm-y) pm-y)
+    (values pm-x pm-y (+ pm-x (pixmap-width pixmap)) (+ pm-y (pixmap-height pixmap)))))
+
+(climi::def-graphic-op draw-pixmap (pixmap pm-x pm-y))
+
+(defmethod medium-draw-pixmap* ((medium clim:medium) pixmap pm-x pm-y)
+  (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap)
+		    medium pm-x pm-y))
+
+(climi::defmethod* (setf output-record-position) :around
+    (nx ny (record draw-pixmap-output-record))
+    (climi::with-standard-rectangle* (:x1 x1 :y1 y1)
+	record
+      (with-slots (pm-x pm-y)
+	  record
+	(let ((dx (- nx x1))
+	      (dy (- ny y1)))
+	  (multiple-value-prog1
+	      (call-next-method)
+	    (incf pm-x dx)
+	    (incf pm-y dy))))))
+
+(climi::defrecord-predicate draw-pixmap-output-record (pm-x pm-y)
+  (and (climi::if-supplied (pm-x coordinate)
+	 (climi::coordinate= (slot-value climi::record 'pm-x) pm-x))
+       (climi::if-supplied (pm-y coordinate)
+	 (climi::coordinate= (slot-value climi::record 'pm-y) pm-y))))
+
+(defun draw-pixmap* (sheet pixmap x y
+			   &rest args
+			   &key clipping-region transformation)
+  (declare (ignore clipping-region transformation))
+  (climi::with-medium-options (sheet args)
+    (medium-draw-pixmap* medium pixmap x y)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -153,10 +159,7 @@
     (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra))
       (let ((x1 (+ x dx))
 	    (y1 (+ (staff-step staff-step) dy)))
-	(when (stream-recording-p pane)
-	  (add-new-pixmap-record 'pixmap-output-record pane pixmap x1 y1))
-	(when (stream-drawing-p pane)
-	  (copy-from-pixmap pixmap 0 0 width height pane x1 y1))))))
+	(draw-pixmap* pane pixmap x1 y1)))))
 
 (defun draw-stack (pane glyph-lower glyph-upper glyph-two x staff-step how-many)
   (draw-antialiased-glyph pane glyph-lower x staff-step)
@@ -179,36 +182,18 @@
 
 ;;;;;;;;;;;;;;;;;; helper macro
 
-(defmacro define-pixmap-recording ((record-name medium-draw-name draw-name args) &body body)
-  `(progn
-    (defclass ,record-name (pixmap-output-record) ())
-    
-    (defgeneric ,medium-draw-name (medium pixmap x y))
-
-    (defmethod ,medium-draw-name ((medium medium) pixmap x y)
-      (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap)
-			medium x y))
-
-    (defmethod ,medium-draw-name ((sheet sheet) pixmap x y)
-      (,medium-draw-name (sheet-medium sheet) pixmap x y))
-
-    (defmethod ,medium-draw-name :around ((pane score-pane) pixmap x y)
-      (when (stream-recording-p pane)
-	(add-new-pixmap-record ',record-name pane pixmap x y))
-      (when (stream-drawing-p pane)
-	(,medium-draw-name (sheet-medium pane) pixmap x y)))
-  
-    (defun ,draw-name (pane , at args x staff-step)
-      (let* ((extra (if *light-glyph* 1 0))
-	     (glyph-no , at body)
-	     (matrix (glyph *font* (+ glyph-no extra)))
-	     (pixmap (pane-pixmap pane matrix)))
-	(multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra))
-	  (,medium-draw-name pane pixmap (+ x dx) (- dy (staff-step staff-step))))))))
+(defmacro define-pixmap-recording ((draw-name args) &body body)
+  `(defun ,draw-name (pane , at args x staff-step)
+     (let* ((extra (if *light-glyph* 1 0))
+	    (glyph-no , at body)
+	    (matrix (glyph *font* (+ glyph-no extra)))
+	    (pixmap (pane-pixmap pane matrix)))
+       (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra))
+	 (draw-pixmap* pane pixmap (+ x dx) (- dy (staff-step staff-step)))))))
 
 ;;;;;;;;;;;;;;;;;; notehead
 
-(define-pixmap-recording (notehead-output-record medium-draw-notehead draw-notehead (name))
+(define-pixmap-recording (draw-notehead (name))
     (ecase name
       (:whole +glyph-whole+)
       (:half +glyph-half+)
@@ -223,7 +208,7 @@
 
 ;;;;;;;;;;;;;;;;;; accidental
 
-(define-pixmap-recording (accidental-output-record medium-draw-accidental draw-accidental (name))
+(define-pixmap-recording (draw-accidental (name))
     (ecase name
       (:natural +glyph-natural+)
       (:flat +glyph-flat+)
@@ -233,7 +218,7 @@
 
 ;;;;;;;;;;;;;;;;;; clef
 
-(define-pixmap-recording (clef-output-record medium-draw-clef draw-clef (name))
+(define-pixmap-recording (draw-clef (name))
     (ecase name
       (:treble +glyph-g-clef+)
       (:bass +glyph-f-clef+)
@@ -248,7 +233,7 @@
 
 ;;;;;;;;;;;;;;;;;; rest
 
-(define-pixmap-recording (rest-output-record medium-draw-rest draw-rest (duration))
+(define-pixmap-recording (draw-rest (duration))
     (ecase duration
       (1 +glyph-whole-rest+)
       (1/2 +glyph-half-rest+)
@@ -261,7 +246,7 @@
 
 ;;;;;;;;;;;;;;;;;; flags down
 
-(define-pixmap-recording (flags-down-output-record medium-draw-flags-down draw-flags-down (nb))
+(define-pixmap-recording (draw-flags-down (nb))
     (ecase nb
       (1 +glyph-flags-down-one+)
       (2 +glyph-flags-down-two+)
@@ -271,7 +256,7 @@
 
 ;;;;;;;;;;;;;;;;;; flags up
 
-(define-pixmap-recording (flags-up-output-record medium-draw-flags-up draw-flags-up (nb))
+(define-pixmap-recording (draw-flags-up (nb))
     (ecase nb
       (1 +glyph-flags-up-one+)
       (2 +glyph-flags-up-two+)
@@ -281,7 +266,7 @@
 
 ;;;;;;;;;;;;;;;;;; dot
 
-(define-pixmap-recording (dot-output-record medium-draw-dot draw-dot ())
+(define-pixmap-recording (draw-dot ())
     +glyph-dot+)
 
 ;;;;;;;;;;;;;;;;;; staff line
@@ -505,30 +490,30 @@
 		      (- x2 x1) 1
 		      medium x1 (- y thickness))))
 
-(defun draw-upward-beam-segment (medium x1 y x2 thickness)
+(defun draw-downward-beam-segment (medium x1 y x2 thickness)
   (draw-segment medium x1 (1+ y) x2 thickness
 		*darker-gray-progressions* *lighter-gray-progressions*))
 
-(defun draw-downward-beam-segment (medium x1 y x2 thickness)
+(defun draw-upward-beam-segment (medium x1 y x2 thickness)
   (draw-segment medium x1 y x2 thickness
 		*lighter-gray-progressions* *darker-gray-progressions*))
 
-(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope)
+(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope)
   (loop for y from y1 below y2
 	for x from x1 by inverse-slope do
-	(draw-upward-beam-segment medium (round x) y
+	(draw-downward-beam-segment medium (round x) y
 				  (round (+ x inverse-slope)) thickness)))
 
-(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope)
+(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope)
   (loop for y from y1 above y2
 	for x from x1 by inverse-slope do
-	(draw-downward-beam-segment medium (round x) y
+	(draw-upward-beam-segment medium (round x) y
 				    (round (+ x inverse-slope)) thickness)))
 
-(defclass upward-beam-output-record (beam-output-record)
+(defclass downward-beam-output-record (beam-output-record)
   ())
 
-(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane)
+(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane)
 				 &optional (region +everywhere+)
 				 (x-offset 0) (y-offset 0))
   (declare (ignore x-offset y-offset region))
@@ -539,13 +524,13 @@
 	  (with-drawing-options (medium :ink ink)
 	    (let ((*lighter-gray-progressions* (lighter-gray-progressions stream))
 		  (*darker-gray-progressions* (darker-gray-progressions stream)))
-	      (draw-upward-beam medium x1 y1 y2 thickness
+	      (draw-downward-beam medium x1 y1 y2 thickness
 					(/ (- x2 x1) (- y2 y1))))))))))
 
-(defclass downward-beam-output-record (beam-output-record)
+(defclass upward-beam-output-record (beam-output-record)
   ())
 
-(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane)
+(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane)
 				 &optional (region +everywhere+)
 				 (x-offset 0) (y-offset 0))
   (declare (ignore x-offset y-offset region))
@@ -556,7 +541,7 @@
 	  (with-drawing-options (medium :ink ink)
 	    (let ((*lighter-gray-progressions* (lighter-gray-progressions stream))
 		  (*darker-gray-progressions* (darker-gray-progressions stream)))
-	      (draw-downward-beam medium x1 y2 y1 thickness
+	      (draw-upward-beam medium x1 y2 y1 thickness
 				  (/ (- x2 x1) (- y2 y1))))))))))
 
 (defun draw-sloped-beam (medium x1 y1 x2 y2 thickness inverse-slope)
@@ -568,11 +553,11 @@
 	       (multiple-value-bind (xx2 yy2)
 		   (transform-position transformation x2 y2)
 		 (stream-add-output-record
-		  *pane* (make-instance 'upward-beam-output-record
+		  *pane* (make-instance 'downward-beam-output-record
 			   :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2
 			   :thickness thickness :ink (medium-ink medium))))))
 	   (when (stream-drawing-p *pane*)
-	     (draw-upward-beam medium x1 y1 y2 thickness inverse-slope)))
+	     (draw-downward-beam medium x1 y1 y2 thickness inverse-slope)))
 	  (t
 	   (when (stream-recording-p *pane*)
 	     (multiple-value-bind (xx1 yy1)
@@ -580,11 +565,11 @@
 	       (multiple-value-bind (xx2 yy2)
 		   (transform-position transformation x2 y2)
 		 (stream-add-output-record
-		  *pane* (make-instance 'downward-beam-output-record
+		  *pane* (make-instance 'upward-beam-output-record
 			   :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2
 			   :thickness thickness :ink (medium-ink medium))))))
 	   (when (stream-drawing-p *pane*)
-	     (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))))))
+	     (draw-upward-beam medium x1 y1 y2 thickness inverse-slope))))))
 
 ;;; an offset of -1 means hang, 0 means straddle and 1 means sit
 (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2)
@@ -627,14 +612,12 @@
 	    (*darker-gray-progressions* (darker-gray-progressions pane))
 	    (,pixmap (allocate-pixmap *pane* 800 900))
 	    (,mirror (sheet-direct-mirror *pane*)))
-;;      (draw-rectangle* ,pixmap 0 0 800 900 :filled t :ink +white+)
-;;      (setf (sheet-direct-mirror *pane*) (climi::pixmap-mirror ,pixmap))
-;;      (clear-output-record (stream-output-history *pane*))
-;;      (with-translation (pane 0 900)
-;;	(with-scaling (pane 1 -1)
-	  , at body ;;))
-;;      (setf (sheet-direct-mirror *pane*) ,mirror)
-;;      (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0)
+      (draw-rectangle* ,pixmap 0 0 800 900 :filled t :ink +white+)
+      (setf (sheet-direct-mirror *pane*) (climi::pixmap-mirror ,pixmap))
+      (clear-output-record (stream-output-history *pane*))
+       , at body
+      (setf (sheet-direct-mirror *pane*) ,mirror)
+      (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0)
       (deallocate-pixmap ,pixmap))))      
 
 (defmacro with-vertical-score-position ((pane yref) &body body)




More information about the Gsharp-cvs mailing list