Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms
In directory clnet:/tmp/cvs-serv934
Modified Files:
gadgets.lisp medium.lisp port.lisp utils.lisp
Log Message:
More little clim-g-f fixes. demodemo still looks terrible but its buttons
work. The Quit menu in the address book works.
* Backends/Graphic-Forms/gadgets.lisp ((REALIZE-MIRROR
PUSH-BUTTON)): Set the dispatcher.
* Backends/Graphic-Forms/medium.lisp (add-medium-to-render): Do it
only if the double buffering image has been installed.
(RENDER-MEDIUM-BUFFER): Renamed from render-medium, since it is
only used for the buffering image. (RENDER-PENDING-MEDIUMS): Use
render-medium-buffer. (INK-TO-COLOR): New function. (TARGET-OF):
Return (and create if needed) image-of, or return the normal
mirror if no buffering has been requested. (TEXT-STYLE-TO-FONT):
New function, based on the old sync-text-style.
(SYNC-TEXT-STYLE): Use text-style-to-font. (MEDIUM-DRAW-POLYGON,
MEDIUM-DRAW-RECTANGLE*): Use the medium ink. Use target-of
instead of image-of. (TEXT-STYLE-*, MEDIUM-DRAW-TEXT*,
MEDIUM-CLEAR-AREA): Use target-of instead of image-of.
(TEXT-SIZE): Merge the text styles properly. (MEDIUM-DRAW-TEXT*):
At least make some effort to draw the text above the y coordinate,
not below it. Probably not correct yet. (MEDIUM-FINISH-OUTPUT,
MEDIUM-FORCE-OUTPUT): Only if image-of is set.
* Backends/Graphic-Forms/port.lisp (GFW-MENU-ITEM-PANE): New slot
callback, needed for those commands that sit directly in the menu
bar. (SHEET-DESIRED-INK): Copy&paste from CLX. (EVENT-PAINT):
Clear the affected area with the desired color when enqueing an
repaint, as expected by the frontend. (EVENT-RESIZE): Resize
image-of only if it exists. (GADGET-EVENT, BUTTON-PRESSED-EVENT):
New classes. (EVENT-SELECT): Handle push buttons. ((HANDLE-EVENT
PUSH-BUTTON BUTTON-PRESSED-EVENT)): New method.
(HANDLE-MENU-CLICKED-EVENT): Call the callback if present.
* Backends/Graphic-Forms/utils.lisp (COORDINATES->POINTS):
Rewritten to loop over the vector (it's not a list).
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/16 14:42:49 1.3
@@ -123,7 +123,11 @@
(defmethod realize-mirror ((port graphic-forms-port) (gadget push-button))
(gfs::debug-format "realizing ~a~%" gadget)
(let* ((parent-mirror (sheet-mirror (sheet-parent gadget)))
- (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:push-button))))
+ (mirror (make-instance 'gfw-button
+ :sheet gadget
+ :parent parent-mirror
+ :dispatcher *pane-dispatcher*
+ :style '(:push-button))))
(if (gadget-label gadget)
(setf (gfw:text mirror) (gadget-label gadget)))
(climi::port-register-mirror port gadget mirror)
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:49:05 1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 14:42:49 1.4
@@ -37,21 +37,45 @@
(defvar *mediums-to-render* nil)
(defun add-medium-to-render (medium)
- (pushnew medium *mediums-to-render* :test #'eql))
+ (when (image-of medium)
+ (pushnew medium *mediums-to-render* :test #'eql)))
(defun remove-medium-to-render (medium)
(setf *mediums-to-render* (remove medium *mediums-to-render*)))
-(defun render-medium (medium)
+(defun render-medium-buffer (medium)
(let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))))
(gfw:with-graphics-context (gc mirror)
(gfg:draw-image gc (image-of medium) *medium-origin*))))
(defun render-pending-mediums ()
(loop for medium in *mediums-to-render*
- do (render-medium medium))
+ do (render-medium-buffer medium))
(setf *mediums-to-render* nil))
+(defun ink-to-color (medium ink)
+ (cond
+ ((eql ink +foreground-ink+)
+ (setf ink (medium-foreground medium)))
+ ((eql ink +background-ink+)
+ (setf ink (medium-background medium))))
+ (multiple-value-bind (red green blue) (clim:color-rgb ink)
+ (gfg:make-color :red (truncate (* red 256))
+ :green (truncate (* green 256))
+ :blue (truncate (* blue 256)))))
+
+(defun target-of (medium)
+ (let ((sheet (medium-sheet medium)))
+ (if (climi::pane-double-buffering sheet)
+ (or (image-of medium)
+ (let* ((region (climi::sheet-mirror-region sheet))
+ (width (floor (bounding-rectangle-max-x region)))
+ (height (floor (bounding-rectangle-max-y region))))
+ (setf (image-of medium)
+ (make-instance 'gfg:image
+ :size (gfs:make-size width height)))))
+ (sheet-mirror (medium-sheet medium)))))
+
(defun resize-medium-buffer (medium size)
(let ((old-image (image-of medium)))
(when old-image
@@ -81,6 +105,19 @@
(symbol (symbol-name text))))
(defun sync-text-style (medium text-style)
+ (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 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)
(text-style-components (merge-text-styles text-style *default-text-style*))
#+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size)
@@ -90,53 +127,47 @@
;; FIXME: externalize these specific choices so that applications can
;; have better control over them
;;
- (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))
- (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc)))
- (face-name (if (stringp family)
- family
- (ecase family
- ((:fix :fixed) "Lucida Console")
- (:serif "Times New Roman")
- (:sans-serif "Arial"))))
- (pnt-size (case size
- (:tiny 6)
- (:very-small 8)
- (:small 10)
- (:normal 12)
- (:large 14)
- (:very-large 16)
- (:huge 18)
- (otherwise 10)))
- (style nil))
- (pushnew (case face
- ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold)
- :bold)
- (otherwise
- :normal))
- style)
- (pushnew (case face
- ((:bold-italic :italic :italic-bold)
- :italic)
- (otherwise
- :normal))
- style)
- (pushnew (case family
- ((:fix :fixed) :fixed)
- (otherwise :normal))
- style)
- (when (or (null old-data)
- (not (eql pnt-size (gfg:font-data-point-size old-data)))
- (string-not-equal face-name (gfg:font-data-face-name old-data))
- (/= (length style)
- (length (intersection style (gfg:font-data-style old-data)))))
- (when old-data
- (gfs:dispose (font-of medium))
- (setf (font-of medium) nil))
- (let ((new-data (gfg:make-font-data :face-name face-name
- :point-size pnt-size
- :style style)))
- #+nil (gfs::debug-format "new font data: ~a~%" new-data)
- (setf (font-of medium) (make-instance 'gfg:font :gc gc :data new-data))))))))
+ (let ((face-name (if (stringp family)
+ family
+ (ecase family
+ ((:fix :fixed) "Lucida Console")
+ (:serif "Times New Roman")
+ (:sans-serif "Arial"))))
+ (pnt-size (case size
+ (:tiny 6)
+ (:very-small 8)
+ (:small 10)
+ (:normal 12)
+ (:large 14)
+ (:very-large 16)
+ (:huge 18)
+ (otherwise 10)))
+ (style nil))
+ (pushnew (case face
+ ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold)
+ :bold)
+ (otherwise
+ :normal))
+ style)
+ (pushnew (case face
+ ((:bold-italic :italic :italic-bold)
+ :italic)
+ (otherwise
+ :normal))
+ style)
+ (pushnew (case family
+ ((:fix :fixed) :fixed)
+ (otherwise :normal))
+ style)
+ (when (or (null old-data)
+ (not (eql pnt-size (gfg:font-data-point-size old-data)))
+ (string-not-equal face-name (gfg:font-data-face-name old-data))
+ (/= (length style)
+ (length (intersection style (gfg:font-data-style old-data)))))
+ (let ((new-data (gfg:make-font-data :face-name face-name
+ :point-size pnt-size
+ :style style)))
+ (make-instance 'gfg:font :gc gc :data new-data))))))
(defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium))
(sync-text-style medium
@@ -190,11 +221,12 @@
(defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled)
#+nil (gfs::debug-format "draw-polygon ~a ~a ~a~%" coord-seq closed filled)
- (when (image-of medium)
- (gfw:with-graphics-context (gc (image-of medium))
- (setf (gfg:background-color gc) gfg:*color-white*
- (gfg:foreground-color gc) gfg:*color-black*)
- (let ((points-list (coordinates->points coord-seq)))
+ (when (target-of medium)
+ (gfw:with-graphics-context (gc (target-of medium))
+ (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)
(if filled
(gfg:draw-filled-polygon gc points-list)
(gfg:draw-polygon gc points-list))))
@@ -202,11 +234,12 @@
(defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled)
#+nil (gfs::debug-format "draw-rectangle ~a ~a ~a ~a ~a~%" left top right bottom filled)
- (when (image-of medium)
- (gfw:with-graphics-context (gc (image-of medium))
- (setf (gfg:background-color gc) gfg:*color-white*
- (gfg:foreground-color gc) gfg:*color-black*)
- (let ((rect (coordinates->rectangle left top right bottom)))
+ (when (target-of medium)
+ (gfw:with-graphics-context (gc (target-of medium))
+ (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))))
@@ -229,21 +262,21 @@
(defmethod text-style-ascent (text-style (medium graphic-forms-medium))
(let ((font (font-of medium)))
(if font
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(gfg:ascent (gfg:metrics gc font)))
1)))
(defmethod text-style-descent (text-style (medium graphic-forms-medium))
(let ((font (font-of medium)))
(if font
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(gfg:descent (gfg:metrics gc font)))
1)))
(defmethod text-style-height (text-style (medium graphic-forms-medium))
(let ((font (font-of medium)))
(if font
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(gfg:height (gfg:metrics gc font)))
1)))
@@ -252,7 +285,7 @@
(width 1)
(text (normalize-text-data char)))
(if font
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(setf (gfg:font gc) font)
(setf width (gfs:size-width (gfg:text-extent gc text)))))
width))
@@ -260,34 +293,30 @@
(defmethod text-style-width (text-style (medium graphic-forms-medium))
(let ((font (font-of medium)))
(if font
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(gfg:average-char-width (gfg:metrics gc font)))
1)))
(defmethod text-size ((medium graphic-forms-medium) string &key text-style (start 0) end)
(setf string (normalize-text-data string))
-#|
- (setf text-style (merge-text-styles (or text-style (make-text-style nil nil nil))
- (medium-default-text-style medium)))
-|#
- ;; FIXME: handle embedded newlines
- ;;
- (let ((font (font-of medium)))
- (if font
- (gfw:with-graphics-context (gc (image-of medium))
- (let ((metrics (gfg:metrics gc font))
- (width (gfs:size-width (gfg:text-extent gc (subseq string
- start
- (or end (length string)))))))
- (values width
- (gfg:height metrics)
- width
- (gfg:height metrics)
- (gfg:ascent metrics))))
- (values 1 1 1 1 1))))
+ (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)))
+ (gfw:with-graphics-context (gc (target-of medium))
+ (let* ((font (text-style-to-font gc text-style nil))
+ (metrics (gfg:metrics gc font))
+ (width (gfs:size-width (gfg:text-extent gc (subseq string
+ start
+ (or end (length string)))))))
+ (values width
+ (gfg:height metrics)
+ width
+ (gfg:height metrics)
+ (gfg:ascent metrics)))))
(defmethod climi::text-bounding-rectangle*
((medium graphic-forms-medium) string &key text-style (start 0) end)
+ ;; fixme, completely wrong
(text-size medium string :text-style text-style :start start :end end))
(defmethod medium-draw-text* ((medium graphic-forms-medium) string x y
@@ -295,15 +324,18 @@
align-x align-y
toward-x toward-y transform-glyphs)
#+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string)
- (when (image-of medium)
+ (when (target-of medium)
(setf string (normalize-text-data string))
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(let ((font (font-of medium)))
(if font
(setf (gfg:font gc) font))
- (gfg:draw-text gc
- (subseq string start (or end (length string)))
- (gfs:make-point :x x :y y))))
+ (let ((h (gfg:height (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 h))))))
(add-medium-to-render medium)))
(defmethod medium-buffering-output-p ((medium graphic-forms-medium))
@@ -318,15 +350,17 @@
())
(defmethod medium-finish-output ((medium graphic-forms-medium))
- (render-medium medium))
+ (when (image-of medium)
+ (render-medium-buffer medium)))
(defmethod medium-force-output ((medium graphic-forms-medium))
- (render-medium medium))
+ (when (image-of medium)
+ (render-medium-buffer medium)))
(defmethod medium-clear-area ((medium graphic-forms-medium) left top right bottom)
- (when (image-of medium)
+ (when (target-of medium)
(let ((rect (coordinates->rectangle left top right bottom)))
- (gfw:with-graphics-context (gc (image-of medium))
+ (gfw:with-graphics-context (gc (target-of medium))
(setf (gfg:background-color gc) gfg:*color-white*
(gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc rect)))
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:49:05 1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4
@@ -59,6 +59,7 @@
:accessor item
:initarg :item
:initform nil)
+ (callback :initarg :value-changed-callback :accessor callback)
(command
:accessor command
:initarg :command
@@ -408,12 +409,35 @@
(setf (event (port self)) (make-instance 'window-manager-delete-event
:sheet (sheet mirror))))
+;; copy&paste from port.lisp|CLX:
+(defun sheet-desired-ink (sheet)
+ (typecase sheet
+ (sheet-with-medium-mixin
+ (medium-background sheet))
+ (basic-pane
+ ;; CHECKME [is this sensible?] seems to be
+ (let ((background (pane-background sheet)))
+ (if (typep background 'color)
+ background
+ +white+)))
+ (t
+ +white+)))
+
(defmethod gfw:event-paint ((self sheet-event-dispatcher) mirror gc rect)
(declare (ignore gc))
(let ((sheet (sheet mirror)))
- (setf (event (port self)) (make-instance 'window-repaint-event
- :sheet sheet
- :region (translate-rectangle rect)))))
+ (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)))
+ (setf (event (port self))
+ (make-instance 'window-repaint-event
+ :sheet sheet
+ :region (translate-rectangle rect)))))
(defun generate-configuration-event (mirror pnt size)
(make-instance 'window-configuration-event
@@ -431,15 +455,26 @@
(let ((sheet (sheet mirror)))
(if (and sheet (subtypep (class-of sheet) 'sheet-with-medium-mixin))
(let ((medium (climi::sheet-medium sheet)))
- (if medium
+ (if (and medium (image-of medium))
(resize-medium-buffer medium size))))
(setf (event (port self))
(generate-configuration-event mirror (gfw:location mirror) size))))
+(defclass gadget-event (window-event) ())
+(defclass button-pressed-event (gadget-event) ())
+
(defmethod gfw:event-select ((self pane-event-dispatcher) mirror)
- (setf (event (port self)) (make-instance 'menu-clicked-event
- :sheet (sheet (gfw:owner mirror))
- :item (sheet mirror))))
+ (setf (event (port self))
+ (typecase mirror
+ (gfw-button
+ (make-instance 'button-pressed-event :sheet (sheet mirror)))
+ (t
+ (make-instance 'menu-clicked-event
+ :sheet (sheet (gfw:owner mirror))
+ :item (sheet mirror))))))
+
+(defmethod handle-event ((pane push-button) (event button-pressed-event))
+ (activate-callback pane (gadget-client pane) (gadget-id pane)))
(defun translate-button-name (name)
(case name
@@ -553,8 +588,9 @@
(if pane
(let ((menu-item (item pane)))
(if menu-item
- (if (eql (command-menu-item-type menu-item) :command)
- (climi::throw-object-ptype menu-item 'menu-item)))))))
+ (if (eql (command-menu-item-type menu-item) :command)
+ (climi::throw-object-ptype menu-item 'menu-item))
+ (funcall (callback pane) pane nil))))))
(defmethod handle-event ((pane gfw-menu-pane) (event menu-clicked-event))
(handle-menu-clicked-event event))
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/16 14:42:51 1.2
@@ -44,10 +44,8 @@
:width (round-coordinate (- right left))
:height (round-coordinate (- bottom top))))
-(defun coordinates->points (list)
- (cond
- ((null list) (values))
- ((and (car list) (cdr list))
- (concatenate 'list (list (gfs:make-point :x (round-coordinate (car list))
- :y (round-coordinate (car (cdr list)))))
- (coordinates->points (cdr (cdr list)))))))
+(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))))))
