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 ,@args x staff-step) - (let* ((extra (if *light-glyph* 1 0)) - (glyph-no ,@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 ,@args x staff-step) + (let* ((extra (if *light-glyph* 1 0)) + (glyph-no ,@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) - ,@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*)) + ,@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)