[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
junrue
junrue at common-lisp.net
Sun Sep 9 03:47:08 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms
In directory clnet:/tmp/cvs-serv13426
Modified Files:
medium.lisp port.lisp utils.lisp
Log Message:
stop setting background color when not rendering filled shapes; get rid of round-coordinate function in favor of simply calling floor; go back to reversing the current pending queue of events; fix a bug in coordinates->points that caused draw-polygon to be called with one less point than was needed; get rid of hard tabs in places I was already editing
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/09/02 23:10:44 1.7
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/09/09 03:47:08 1.8
@@ -114,14 +114,14 @@
(gfw:with-graphics-context
(gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))
(let* ((old-data
- (when (font-of medium)
- (gfg:data-object (font-of medium) gc)))
- (new-font (text-style-to-font gc text-style old-data)))
+ (when (font-of medium)
+ (gfg:data-object (font-of medium) gc)))
+ (new-font (text-style-to-font gc text-style old-data)))
(when new-font
- (when old-data
- (gfs:dispose (font-of medium))
- (setf (font-of medium) nil))
- (setf (font-of medium) new-font)))))
+ (when old-data
+ (gfs:dispose (font-of medium))
+ (setf (font-of medium) nil))
+ (setf (font-of medium) new-font)))))
(defun text-style-to-font (gc text-style old-data)
(multiple-value-bind (family face size)
@@ -212,148 +212,148 @@
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color))
+ (setf (gfg:foreground-color gc) color))
(let ((tr (sheet-native-transformation (medium-sheet medium))))
- (climi::with-transformed-position (tr x y)
- (gfg:draw-point gc (gfs:make-point :x (round-coordinate x)
- :y (round-coordinate y))))))
+ (climi::with-transformed-position (tr x y)
+ (gfg:draw-point gc (gfs:make-point :x (floor x)
+ :y (floor y))))))
(add-medium-to-render medium)))
(defmethod medium-draw-points* ((medium graphic-forms-medium) coord-seq)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color))
+ (setf (gfg:foreground-color gc) color))
(let ((tr (sheet-native-transformation (medium-sheet medium))))
- (loop for (x y) on (coerce coord-seq 'list) by #'cddr do
- (climi::with-transformed-position (tr x y)
- (gfg:draw-point gc
- (gfs:make-point :x (round-coordinate x)
- :y (round-coordinate y)))))))
+ (loop for (x y) on (coerce coord-seq 'list) by #'cddr do
+ (climi::with-transformed-position (tr x y)
+ (gfg:draw-point gc
+ (gfs:make-point :x (floor x)
+ :y (floor y)))))))
(add-medium-to-render medium)))
(defmethod medium-draw-line* ((medium graphic-forms-medium) x1 y1 x2 y2)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color))
+ (setf (gfg:foreground-color gc) color))
(let ((tr (sheet-native-transformation (medium-sheet medium))))
- (climi::with-transformed-position (tr x1 y1)
- (climi::with-transformed-position (tr x2 y2)
- (gfg:draw-line gc
- (gfs:make-point :x (round-coordinate x1)
- :y (round-coordinate y1))
- (gfs:make-point :x (round-coordinate x2)
- :y (round-coordinate y2)))))))
+ (climi::with-transformed-position (tr x1 y1)
+ (climi::with-transformed-position (tr x2 y2)
+ (gfg:draw-line gc
+ (gfs:make-point :x (floor x1)
+ :y (floor y1))
+ (gfs:make-point :x (floor x2)
+ :y (floor y2)))))))
(add-medium-to-render medium)))
(defmethod medium-draw-lines* ((medium graphic-forms-medium) coord-seq)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color))
+ (setf (gfg:foreground-color gc) color))
(let ((tr (sheet-native-transformation (medium-sheet medium))))
- (loop for (x1 y1 x2 y2) on (coerce coord-seq 'list) by #'cddddr do
- (climi::with-transformed-position (tr x1 y1)
- (climi::with-transformed-position (tr x2 y2)
- (gfg:draw-line gc
- (gfs:make-point :x (round-coordinate x1)
- :y (round-coordinate y1))
- (gfs:make-point :x (round-coordinate x2)
- :y (round-coordinate y2))))))))
+ (loop for (x1 y1 x2 y2) on (coerce coord-seq 'list) by #'cddddr do
+ (climi::with-transformed-position (tr x1 y1)
+ (climi::with-transformed-position (tr x2 y2)
+ (gfg:draw-line gc
+ (gfs:make-point :x (floor x1)
+ :y (floor y1))
+ (gfs:make-point :x (floor x2)
+ :y (floor y2))))))))
(add-medium-to-render medium)))
(defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(climi::with-transformed-positions
- ((sheet-native-transformation (medium-sheet medium)) coord-seq)
- (let ((points-list (coordinates->points coord-seq))
- (color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color)
- (when (and closed (not filled))
- (push (car (last points-list)) points-list))
- (if filled
- (gfg:draw-filled-polygon gc points-list)
- (gfg:draw-polygon gc points-list)))))
+ ((sheet-native-transformation (medium-sheet medium)) coord-seq)
+ (let ((points-list (coordinates->points coord-seq))
+ (color (ink-to-color medium (medium-ink medium))))
+ (if filled
+ (setf (gfg:background-color gc) color))
+ (setf (gfg:foreground-color gc) color)
+ (when (and closed (not filled))
+ (push (car (last points-list)) points-list))
+ (if filled
+ (gfg:draw-filled-polygon gc points-list)
+ (gfg:draw-polygon gc points-list)))))
(add-medium-to-render medium)))
(defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((tr (sheet-native-transformation (medium-sheet medium))))
- (climi::with-transformed-position (tr left top)
- (climi::with-transformed-position (tr right bottom)
- (let ((rect (coordinates->rectangle left top right bottom))
- (color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color)
- (if filled
- (gfg:draw-filled-rectangle gc rect)
- (gfg:draw-rectangle gc rect)))))))
+ (climi::with-transformed-position (tr left top)
+ (climi::with-transformed-position (tr right bottom)
+ (let ((rect (coordinates->rectangle left top right bottom))
+ (color (ink-to-color medium (medium-ink medium))))
+ (if filled
+ (setf (gfg:background-color gc) color))
+ (setf (gfg:foreground-color gc) color)
+ (if filled
+ (gfg:draw-filled-rectangle gc rect)
+ (gfg:draw-rectangle gc rect)))))))
(add-medium-to-render medium)))
(defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled)
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((tr (sheet-native-transformation (medium-sheet medium)))
- (color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color)
- (loop for i below (length position-seq) by 4 do
- (let ((x1 (round-coordinate (elt position-seq (+ i 0))))
- (y1 (round-coordinate (elt position-seq (+ i 1))))
- (x2 (round-coordinate (elt position-seq (+ i 2))))
- (y2 (round-coordinate (elt position-seq (+ i 3)))))
- (climi::with-transformed-position (tr x1 y1)
- (climi::with-transformed-position (tr x2 y2)
- (let ((rect (coordinates->rectangle x1 y1 x2 y2)))
- (if filled
- (gfg:draw-filled-rectangle gc rect)
- (gfg:draw-rectangle gc rect)))))))))
+ (color (ink-to-color medium (medium-ink medium))))
+ (if filled
+ (setf (gfg:background-color gc) color))
+ (setf (gfg:foreground-color gc) color)
+ (loop for i below (length position-seq) by 4 do
+ (let ((x1 (floor (elt position-seq (+ i 0))))
+ (y1 (floor (elt position-seq (+ i 1))))
+ (x2 (floor (elt position-seq (+ i 2))))
+ (y2 (floor (elt position-seq (+ i 3)))))
+ (climi::with-transformed-position (tr x1 y1)
+ (climi::with-transformed-position (tr x2 y2)
+ (let ((rect (coordinates->rectangle x1 y1 x2 y2)))
+ (if filled
+ (gfg:draw-filled-rectangle gc rect)
+ (gfg:draw-rectangle gc rect)))))))))
(add-medium-to-render medium)))
;; FIXME: completely untested. Not sure we're even using the right GFG h
;; functions. Are start-point and end-point right?
(defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y
- radius-1-dx radius-1-dy
- radius-2-dx radius-2-dy
- start-angle end-angle filled)
+ radius-1-dx radius-1-dy
+ radius-2-dx radius-2-dy
+ start-angle end-angle filled)
(unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0))
(error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses."))
(when (target-of medium)
(gfw:with-graphics-context (gc (target-of medium))
(let ((color (ink-to-color medium (medium-ink medium))))
- (setf (gfg:background-color gc) color
- (gfg:foreground-color gc) color))
+ (if filled
+ (setf (gfg:background-color gc) color))
+ (setf (gfg:foreground-color gc) color))
(climi::with-transformed-position
- ((sheet-native-transformation (medium-sheet medium))
- center-x center-y)
- (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx)))
- (radius-dy (abs (+ radius-1-dy radius-2-dy)))
- (min-x (round-coordinate (- center-x radius-dx)))
- (min-y (round-coordinate (- center-y radius-dy)))
- (max-x (round-coordinate (+ center-x radius-dx)))
- (max-y (round-coordinate (+ center-y radius-dy)))
- (rect (coordinates->rectangle min-x min-y max-x max-y))
- (start-point
- (gfs:make-point :x (round-coordinate
- (* (cos start-angle) radius-dx))
- :y (round-coordinate
- (* (sin start-angle) radius-dy))))
- (end-point
- (gfs:make-point :x (round-coordinate
- (* (cos end-angle) radius-dx))
- :y (round-coordinate
- (* (sin end-angle) radius-dy)))))
- (if filled
- (gfg:draw-filled-pie-wedge gc rect start-point end-point)
- (gfg:draw-pie-wedge gc rect start-point end-point)))))
+ ((sheet-native-transformation (medium-sheet medium))
+ center-x center-y)
+ (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx)))
+ (radius-dy (abs (+ radius-1-dy radius-2-dy)))
+ (min-x (floor (- center-x radius-dx)))
+ (min-y (floor (- center-y radius-dy)))
+ (max-x (floor (+ center-x radius-dx)))
+ (max-y (floor (+ center-y radius-dy)))
+ (rect (coordinates->rectangle min-x min-y max-x max-y))
+ (start-point
+ (gfs:make-point :x (floor
+ (* (cos start-angle) radius-dx))
+ :y (floor
+ (* (sin start-angle) radius-dy))))
+ (end-point
+ (gfs:make-point :x (floor
+ (* (cos end-angle) radius-dx))
+ :y (floor
+ (* (sin end-angle) radius-dy)))))
+ (if filled
+ (gfg:draw-filled-pie-wedge gc rect start-point end-point)
+ (gfg:draw-pie-wedge gc rect start-point end-point)))))
(add-medium-to-render medium)))
;; FIXME: completely untested.
@@ -410,8 +410,9 @@
(setf text-style (or text-style (make-text-style nil nil nil)))
(setf text-style
(merge-text-styles text-style (medium-default-text-style medium)))
+ (sync-text-style medium text-style)
(gfw:with-graphics-context (gc (target-of medium))
- (let ((font (text-style-to-font gc text-style nil)))
+ (let ((font (font-of medium)))
(setf (gfg:font gc) font)
(let ((metrics (gfg:metrics gc font))
(extent (gfg:text-extent gc (subseq string
@@ -441,13 +442,13 @@
(gfw:with-graphics-context (gc (target-of medium))
(let ((font (font-of medium)))
(if font
- (setf (gfg:font gc) font))
+ (setf (gfg:font gc) font))
(let ((ascent (gfg:ascent (gfg:metrics gc font)))
- (x (round-coordinate x))
- (y (round-coordinate y)))
- (gfg:draw-text gc
- (subseq string start (or end (length string)))
- (gfs:make-point :x x :y (- y ascent))))))
+ (x (floor x))
+ (y (floor y)))
+ (gfg:draw-text gc
+ (subseq string start (or end (length string)))
+ (gfs:make-point :x x :y (- y ascent))))))
(add-medium-to-render medium)))
(defmethod medium-buffering-output-p ((medium graphic-forms-medium))
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/09/08 23:54:49 1.7
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/09/09 03:47:08 1.8
@@ -170,14 +170,14 @@
;;;
(defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gfw-top-level) region)
- (let ((size (gfs:make-size :width (round-coordinate (bounding-rectangle-width region))
- :height (round-coordinate (bounding-rectangle-height region)))))
+ (let ((size (gfs:make-size :width (floor (bounding-rectangle-width region))
+ :height (floor (bounding-rectangle-height region)))))
(setf (gfw:size mirror) (gfw::compute-outer-size mirror size))))
(defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gf-mirror-mixin) region)
(setf (gfw:size mirror)
- (gfs:make-size :width (round-coordinate (bounding-rectangle-width region))
- :height (round-coordinate (bounding-rectangle-height region)))))
+ (gfs:make-size :width (floor (bounding-rectangle-width region))
+ :height (floor (bounding-rectangle-height region)))))
(defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gfw-menu) region)
(declare (ignore port mirror region)))
@@ -193,8 +193,8 @@
(multiple-value-bind (x y)
(transform-position transformation 0 0)
(setf (gfw:location mirror)
- (gfs:make-point :x (round-coordinate x)
- :y (round-coordinate y)))))
+ (gfs:make-point :x (floor x)
+ :y (floor y)))))
(defmethod port-set-mirror-transformation ((port graphic-forms-port) (mirror gfw-menu) transformation)
(declare (ignore port mirror transformation)))
@@ -211,7 +211,7 @@
(let* ((mirror (make-instance 'gfw-top-level
:sheet sheet
:dispatcher *sheet-dispatcher*
- :style '(:frame)
+ :style '(:workspace)
:text (frame-pretty-name (pane-frame sheet)))))
(let ((menu-bar (make-instance 'gfw-menu :handle (gfs::create-menu))))
(gfw::put-widget (gfw::thread-context) menu-bar)
@@ -266,6 +266,7 @@
(cffi:with-foreign-object (msg-ptr 'gfs::msg)
(let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)))
(gfw::default-message-filter gm msg-ptr))
+ (setf (events port) (nreverse (events port)))
(pop (events port)))))
(defmethod process-next-event :after ((port graphic-forms-port) &key wait-function (timeout nil))
@@ -414,20 +415,18 @@
+white+)))
(defmethod gfw:event-paint ((self sheet-event-dispatcher) mirror gc rect)
- (declare (ignore gc))
(let ((sheet (sheet mirror)))
(when (and (typep sheet 'sheet-with-medium-mixin)
- (not (image-of (sheet-medium sheet))))
- (gfw:with-graphics-context (gc mirror)
- (let ((c (ink-to-color (sheet-medium sheet)
- (sheet-desired-ink sheet))))
- (setf (gfg:background-color gc) c
- (gfg:foreground-color gc) c))
- (gfg:draw-filled-rectangle gc rect)))
+ (not (image-of (sheet-medium sheet))))
+ (let ((c (ink-to-color (sheet-medium sheet)
+ (sheet-desired-ink sheet))))
+ (setf (gfg:background-color gc) c
+ (gfg:foreground-color gc) c))
+ (gfg:draw-filled-rectangle gc rect))
(enqueue (port self)
- (make-instance 'window-repaint-event
- :sheet sheet
- :region (translate-rectangle rect)))))
+ (make-instance 'window-repaint-event
+ :sheet sheet
+ :region (translate-rectangle rect)))))
(defun generate-configuration-event (mirror pnt size)
(make-instance 'window-configuration-event
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/16 14:42:51 1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/09/09 03:47:08 1.3
@@ -21,13 +21,9 @@
(in-package :clim-graphic-forms)
-(declaim (inline round-coordinate))
-(defun round-coordinate (x)
- (floor (+ x .5)))
-
(defun requirement->size (req)
- (gfs:make-size :width (round-coordinate (space-requirement-width req))
- :height (round-coordinate (space-requirement-height req))))
+ (gfs:make-size :width (floor (space-requirement-width req))
+ :height (floor (space-requirement-height req))))
(defun translate-rectangle (gfw-rect)
(let ((pnt (gfs:location gfw-rect))
@@ -39,13 +35,12 @@
(declaim (inline coordinates->rectangle))
(defun coordinates->rectangle (left top right bottom)
- (gfs:create-rectangle :x (round-coordinate left)
- :y (round-coordinate top)
- :width (round-coordinate (- right left))
- :height (round-coordinate (- bottom top))))
+ (gfs:create-rectangle :x (floor left)
+ :y (floor top)
+ :width (floor (- right left))
+ :height (floor (- bottom top))))
(defun coordinates->points (seq)
- (loop for i from 2 below (length seq) by 2
- collect
- (gfs:make-point :x (round-coordinate (elt seq i))
- :y (round-coordinate (elt seq (+ i 1))))))
+ (loop for i from 0 below (length seq) by 2
+ collect (gfs:make-point :x (floor (elt seq i))
+ :y (floor (elt seq (+ i 1))))))
More information about the Mcclim-cvs
mailing list