Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv11052
Modified Files: NOTES clim-fix.lisp event.lisp gadgets.lisp gtk-ffi.lisp medium.lisp port.lisp Added Files: BUGS Log Message: * medium.lisp (GTKAIRO-MEDIUM, LAST-SEEN-SHEET, LAST-SEEN-REGION, INITIALIZE-INSTANCE, SHEET-CHANGED-BEHIND-OUR-BACK-P, SYNC-SHEET): Reinstate the last-seen-sheet logic, required for the pixmap trickery in drag&drop. (*ANTIALIASINGP*): Set to T again! (SYNC-TRANSFORMATION): Use the identity transformation for mediums without a sheet. (DRAW-ELLIPSE*, SYNC-TRANSFORMATION): Handle an additional transformation argument again. Fixes ellipse drawing to at least not error out. (CLIMI::TEXT-BOUNDING-RECTANGLE*): Use x_bearing+width instead of x_advance. Seems to look correct in the visual test now (try italic f). (flipping-original-cr, flipping-pixmap, invoke-with-cairo-medium, apply-flipping-ink, (sync-ink standard-flipping-ink)): Implemented flipping ink.
* gtk-ffi.lisp (gdk_gc_set_function, gtk_widget_size_request): New functions. (gdkfunction): Enum. (gtkrequisition): Struct.
* event.lisp (connect-signals, noop-handler): Override focus-in/out to reduce flicker. (gtk-main-iteration): Oops. If `block' is given, make it so.
* clim-fix.lisp (highlight-output-record-rectangle): Adjust rectangle coordinates by half a pixel each to avoid anti-aliasing (and follow-up output artifacts).
* port.lisp (port-set-mirror-region, mirror, mirror-region): Don't resize if the region hasn't actually changed. (gtk-widget-modify-bg, sheet-desired-color, realize-mirror): New wrapper function gtk-widget-modify-bg for gtk_widget_modify_bg. (native-widget-mixin, native-widget, (destroy-mirror native-widget-mixin)): New Accessor native-widget. ((realize-mirror native-widget-mixin)): Create the native widget before asking the sheet for space requirements.
* gadgets.lisp ((realize-native-widget gtk-button)): Set button background color to pane-background. See BUGS. (gtk-button): Subclass the abstract gadgets, not the virtual default panes. (compose-space): Ask GTK+ for default sizes.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/23 10:18:45 1.2 @@ -113,7 +113,11 @@ ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation.
-[ David: Das ginge auch mit Cairo, ja. ] +[ David: I have implemented this strategy now. We draw flipping ink to + a gdk pixmap, then copy that over with GDK_XOR. And indeed, Goatee + now is extremely slow over remote X because it uses flipping ink. + FIXME: Although simple cases work, sometimes flipping ink now causes + garbage output to appear. ]
;; - flipping ink ;; @@ -125,3 +129,6 @@ ;; But: A flippink can't be solved by just setting up the proper Cairo pattern ;; to a Cairo context, but drawing the shape itself must happen on our ;; temporary surface. + +[ David: see above for my implemenation of flipping ink. Not sure how the + alpha channel is meant to be handled though. ] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/23 10:18:45 1.2 @@ -24,3 +24,24 @@
(defmethod clim:handle-repaint :after ((s clim:sheet-with-medium-mixin) r) (medium-force-output (sheet-medium s))) + +;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid +;; anti-aliasing (and follow-up output artifacts) +(defun highlight-output-record-rectangle (record stream state) + (with-identity-transformation (stream) + (multiple-value-bind (x1 y1 x2 y2) + (output-record-hit-detection-rectangle* record) + (ecase state + (:highlight + (draw-rectangle* (sheet-medium stream) + (+ (ceiling x1) 0.5d0) + (+ (ceiling y1) 0.5d0) + (+ (floor (1- x2)) 0.5d0) + (+ (floor (1- y2)) 0.5d0) + ;; XXX +FLIPPING-INK+? + :filled nil :ink +foreground-ink+)) + (:unhighlight + ;; FIXME: repaint the hit detection rectangle. It could be + ;; bigger than + ;; the bounding rectangle. + (repaint-sheet stream record)))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:46:18 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/23 10:18:45 1.3 @@ -50,7 +50,11 @@ (connect-signal widget "key-release-event" 'key-handler) (connect-signal widget "enter-notify-event" 'enter-handler) (connect-signal widget "leave-notify-event" 'leave-handler) - (connect-signal widget "configure-event" 'configure-handler)) + (connect-signal widget "configure-event" 'configure-handler) + ;; override gtkwidget's focus handlers, which trigger an expose event, + ;; causing unnecessary redraws for mouse movement + (connect-signal widget "focus-in-event" 'noop-handler) + (connect-signal widget "focus-out-event" 'noop-handler))
(defun connect-window-signals (widget) (gtk_widget_add_events widget (logior GDK_STRUCTURE_MASK @@ -85,8 +89,10 @@ (defun gtk-main-iteration (port &optional block) (with-gtk () (let ((*port* port)) - (while (plusp (gtk_events_pending)) - (gtk_main_iteration_do (if block 1 0)))))) + (if block + (gtk_main_iteration_do 1) + (while (plusp (gtk_events_pending)) + (gtk_main_iteration_do 0))))))
(defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) @@ -111,6 +117,8 @@ data (,impl widget event)))))
+(define-signal noop-handler (widget event)) + (define-signal expose-handler (widget event) (enqueue (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/23 10:18:45 1.2 @@ -33,7 +33,7 @@ ;; vielleicht, von TOGGLE-BUTTON statt TOGGLE-BUTTON-PANE zu erben und ;; alles selbst zu machen. Mindestens COMPOSE-SPACE muesste man dann ;; hier implementieren. -(defclass gtk-button (native-widget-mixin push-button-pane) ()) +(defclass gtk-button (native-widget-mixin push-button) ()) (defclass gtk-check-button (native-widget-mixin toggle-button-pane) ()) (defclass gtk-radio-button (native-widget-mixin toggle-button-pane) ()) (defclass gtk-vscale (native-widget-mixin slider-pane) ()) @@ -45,7 +45,10 @@ ;;;; Constructors
(defmethod realize-native-widget ((sheet gtk-button)) - (gtk_button_new_with_label (climi::gadget-label sheet))) + (let ((button (gtk_button_new_with_label (climi::gadget-label sheet)))) + (when (pane-background sheet) + (gtk-widget-modify-bg button (pane-background sheet))) + button))
(defmethod realize-native-widget ((sheet gtk-check-button)) (gtk_check_button_new_with_label (climi::gadget-label sheet))) @@ -166,3 +169,18 @@ ;; see hack in clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) + +;; KLUDGE: this is getting called before the sheet has been realized. +(defmethod compose-space ((gadget native-widget-mixin) &key width height) + (declare (ignore width height)) + (let* ((widget (native-widget gadget)) + (widgetp widget)) + (unless widgetp + (setf widget (realize-native-widget gadget))) + (prog1 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request widget r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (make-space-requirement :width width :height height))) + (unless widgetp + (gtk_widget_destroy widget))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:46:18 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/23 10:18:45 1.3 @@ -139,6 +139,10 @@ (gdkwindow :pointer) (parent :pointer))
+(cffi:defcstruct gtkrequisition + (width :int) + (height :int)) + (defun gtkwidget-header (widget) (cffi:foreign-slot-value widget 'gtkwidget 'header))
@@ -253,6 +257,10 @@ (max_aspect :double) (win_gravity :int))
+(cffi:defcenum gdkfunction + :copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv + :or_reverse :copy_invert :or_invert :nand :nor :set) +
;;; GTK functions
@@ -322,6 +330,11 @@ (width :pointer) (height :pointer))
+(defcfun "gtk_widget_size_request" + :void + (widget :pointer) + (requisition :pointer)) + (defcfun "gtk_container_add" :void (parent :pointer) @@ -534,6 +547,11 @@ :void (drawable :pointer))
+(defcfun "gdk_gc_set_function" + :void + (gc :pointer) + (function gdkfunction)) + (defcfun "gdk_draw_drawable" :void (drawable :pointer) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:48:52 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 10:18:45 1.3 @@ -32,7 +32,16 @@ (defclass gtkairo-medium (climi::basic-medium clim:medium) ((port :initarg :port :accessor port) (cr :initform nil :initarg :cr :accessor cr) - (surface :initarg :surface :accessor surface))) + (flipping-original-cr :initform nil :accessor flipping-original-cr) + (flipping-pixmap :accessor flipping-pixmap) + (surface :initarg :surface :accessor surface) + (last-seen-sheet :accessor last-seen-sheet) + (last-seen-region :accessor last-seen-region))) + +(defmethod initialize-instance :after + ((instance gtkairo-medium) &key cr) + (unless cr + (setf (last-seen-sheet instance) nil)))
(defclass metrik-medium (gtkairo-medium) ()) @@ -43,7 +52,7 @@ ;; artifacts remain around lines that are blurry with antialiasing ;; enabled, which perhaps points to round-off error being the reason for ;; both blurryness and visual artifacts. Both need to be fixed. -(defparameter *antialiasingp* nil) +(defparameter *antialiasingp* t)
(defun gtkwidget-gdkwindow (widget) (cffi:foreign-slot-value widget 'gtkwidget 'gdkwindow)) @@ -59,16 +68,28 @@ (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) (with-gtk () - (funcall fn)))) + (multiple-value-prog1 + (funcall fn) + (when (flipping-original-cr medium) + (apply-flipping-ink medium)))))) + +(defun sheet-changed-behind-our-back-p (medium) + (and (slot-boundp medium 'last-seen-sheet) + (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) + (not (region-equal (last-seen-region medium) + (sheet-region (medium-sheet medium)))))))
(defun sync-sheet (medium) - (unless (cr medium) + (when (or (null (cr medium)) + (sheet-changed-behind-our-back-p medium)) (with-cairo-medium (medium) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) (push medium (mirror-mediums mirror)) - (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1)))))) + (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1))) + (setf (last-seen-sheet medium) (medium-sheet medium)) + (setf (last-seen-region medium) (sheet-region (medium-sheet medium))))))
;;;; ------------------------------------------------------------------------ @@ -88,16 +109,21 @@ ;;;; Drawing Options ;;;;
-(defun sync-transformation (medium) +(defun sync-transformation (medium &optional extra-transformation) (with-slots (cr) medium (cffi:with-foreign-object (matrix 'cairo_matrix_t) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation - (sheet-native-transformation (medium-sheet medium))) - (cairo_matrix_init matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (cairo_set_matrix cr matrix))))) + (let ((tr + (if (medium-sheet medium) + (sheet-native-transformation (medium-sheet medium)) + clim:+identity-transformation+))) + (when extra-transformation + (setf tr (compose-transformations extra-transformation tr))) + (multiple-value-bind (mxx mxy myx myy tx ty) + (climi::get-transformation tr) + (cairo_matrix_init matrix + (df mxx) (df mxy) (df myx) (df myy) + (df tx) (df ty)) + (cairo_set_matrix cr matrix))))))
(defmacro with-cairo-matrix ((matrix transformation) &body body) `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) @@ -182,11 +208,39 @@ (cairo_pattern_set_matrix p matrix)) p)))
+(defun apply-flipping-ink (medium) + (let ((from-surface (cairo_get_target (cr medium))) + (from-drawable (flipping-pixmap medium)) + (to-surface (cairo_get_target (flipping-original-cr medium))) + (to-drawable (medium-gdkdrawable medium))) + (cairo_surface_flush from-surface) + (cairo_surface_flush to-surface) + (let ((gc (gdk_gc_new to-drawable))) + (gdk_gc_set_function gc :xor) + (cffi:with-foreign-slots ((allocation-width allocation-height) + (mirror-widget (medium-mirror medium)) + gtkwidget) + (gdk_draw_drawable to-drawable gc from-drawable 0 0 0 0 + allocation-width allocation-height)) + (gdk_gc_unref gc)) + (cairo_surface_mark_dirty to-surface)) + (cairo_destroy (cr medium)) + (setf (cr medium) (flipping-original-cr medium)) + (setf (flipping-original-cr medium) nil)) + (defmethod sync-ink (medium (design climi::standard-flipping-ink)) - (with-slots ((d1 climi::design1) (d2 climi::design2)) design - (with-slots (cr) medium - (cairo_set_source_rgba cr 1.0d0 1.0d0 1.0d0 1d0) - (cairo_set_operator cr :xor)))) + (setf (flipping-original-cr medium) (cr medium)) + (let* ((mirror (medium-mirror medium)) + (drawable (mirror-drawable mirror))) + (cffi:with-foreign-slots ((allocation-width allocation-height) + (mirror-widget mirror) + gtkwidget) + (let ((pixmap + (gdk_pixmap_new drawable allocation-width allocation-height -1))) + (setf (cr medium) (gdk_cairo_create pixmap)) + (setf (flipping-pixmap medium) pixmap) + (sync-transformation medium) + (sync-ink medium +white+)))))
(defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) @@ -524,9 +578,7 @@ (+ cx rx2) (+ cy ry2)))) (sync-sheet medium) ;; hmm, something is wrong here. - (sync-transformation - medium - (compose-transformations tr (medium-transformation medium))) + (sync-transformation medium tr) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) @@ -809,11 +861,11 @@ ;; whether it's 100% right: ;; --DFL (cffi:with-foreign-slots - ((height x_advance y_advance x_bearing y_bearing) + ((width height x_advance y_advance x_bearing y_bearing) res cairo_text_extents) - (values (ceiling x_bearing) - (ceiling y_bearing) - (ceiling x_advance) + (values (floor x_bearing) + (floor y_bearing) + (ceiling (+ width (max 0 x_bearing))) (ceiling (+ height y_bearing))))))))
;;;; ------------------------------------------------------------------------ --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/23 10:18:45 1.2 @@ -102,7 +102,8 @@ ;;;; Mirrors
(defclass mirror () - ((mediums :initform '() :accessor mirror-mediums))) + ((mediums :initform '() :accessor mirror-mediums) + (region :initform nil :accessor mirror-region)))
(defclass widget-mirror (mirror) ((widget :initarg :widget :accessor mirror-widget) @@ -181,24 +182,32 @@ ((port gtkairo-port) (sheet climi::unmanaged-top-level-sheet-pane)) (realize-window-mirror port sheet GTK_WINDOW_POPUP))
+(defun gtk-widget-modify-bg (widget color) + (cffi:with-foreign-object (c 'gdkcolor) + (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) + (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) + (cffi:foreign-slot-value c 'gdkcolor 'g) + (cffi:foreign-slot-value c 'gdkcolor 'b)) + (multiple-value-bind (r g b) + (color-rgb color) + (values (min (truncate (* r 65536)) 65535) + (min (truncate (* g 65536)) 65535) + (min (truncate (* b 65536)) 65535)))) + (gtk_widget_modify_bg widget 0 c))) + ;; copy&paste from port.lisp|CLX: (defun sheet-desired-color (sheet) - (multiple-value-bind (r g b) - (color-rgb - (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+))) - (values (min (truncate (* r 65536)) 65535) - (min (truncate (* g 65536)) 65535) - (min (truncate (* b 65536)) 65535)))) + (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 realize-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () @@ -223,25 +232,21 @@ (setf y (round-coordinate y)) (gtk_fixed_put (mirror-widget parent) widget x y)) (climi::port-register-mirror (port sheet) sheet mirror) - (cffi:with-foreign-object (color 'gdkcolor) - (setf (cffi:foreign-slot-value color 'gdkcolor 'pixel) 0) - (setf (values (cffi:foreign-slot-value color 'gdkcolor 'r) - (cffi:foreign-slot-value color 'gdkcolor 'g) - (cffi:foreign-slot-value color 'gdkcolor 'b)) - (sheet-desired-color sheet)) - (gtk_widget_modify_bg widget 0 color)) + (gtk-widget-modify-bg widget (sheet-desired-color sheet)) (when (sheet-enabled-p sheet) (gtk_widget_show widget)) mirror)))
-(defclass native-widget-mixin () ()) +(defclass native-widget-mixin () + ((widget :initform nil :accessor native-widget)))
(defmethod realize-mirror ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () - (let* ((parent (sheet-mirror (sheet-parent sheet))) + (setf (native-widget sheet) (realize-native-widget sheet)) + (let* ((widget (native-widget sheet)) + (parent (sheet-mirror (sheet-parent sheet))) (q (compose-space sheet)) (fixed (gtk_fixed_new)) - (widget (realize-native-widget sheet)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror @@ -312,6 +317,10 @@ (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil))))
+(defmethod destroy-mirror :after + ((port gtkairo-port) (sheet native-widget-mixin)) + (setf (native-widget sheet) nil)) + (defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) @@ -346,12 +355,15 @@
(defmethod port-set-mirror-region ((port gtkairo-port) (mirror mirror) mirror-region) - (with-gtk () - (reset-mediums mirror) - (gtk_widget_set_size_request - (mirror-widget mirror) - (floor (bounding-rectangle-max-x mirror-region)) - (floor (bounding-rectangle-max-y mirror-region))))) + (unless (and (mirror-region mirror) + (region-equal (mirror-region mirror) mirror-region)) + (with-gtk () + (reset-mediums mirror) + (gtk_widget_set_size_request + (mirror-widget mirror) + (floor (bounding-rectangle-max-x mirror-region)) + (floor (bounding-rectangle-max-y mirror-region)))) + (setf (mirror-region mirror) mirror-region)))
(defmethod port-set-mirror-region ((port gtkairo-port) (mirror native-widget-mirror) mirror-region)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:18:45 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:18:45 1.1 1. In the address book example example, the input cursor when typing and erasing characters is not getting removed properly, leaving a trace.
2. Also, the presentation highlighting rectangle leaves traces if antialiasing is enabled.
3. The text cursor does not show the correct horizontal position in climacs.
4. Menus appear but do not really work. Worth fixing, even though we would rather want native menus in the long term.
5a. Colored buttons (clim-fig) are missing.
5b. the slider is not quite right.
5c. Inheriting from the standard gadget panes is bogus anyway, we should build them from scratch.
5d. Default gadget values aren't being used.
6. Should work on Windows but does not. Using the installer from gimp-win.sf.net I see an address book window, but there are cairo font warnings in the background and moving the mouse gives an error. Although the hordes of sbcl/win32 hackers might contribute a native Windows backend sooner or later, it would be nice to get Gtkairo working on Windows, too.
7. (some?) drawing operations are rather slow. (Remote X to an ancient server spends insane amounts of real (!) time doing XGetImage requests. But even locally, where that isn't reproducable, it's not really snappy. Just try scrolling in beirc.)
8. The frontend specifies background colors (*3d-normal-color*) where the gtk theme should take precedence.
9. Sometimes repaint seems to draw again without clearing the window first. For example, the header in demodemo gets darker with every repaint, until the originally antialiased text looks really crappy. (Now that mouse movement doesn't trigger repaints anymore this is harder to reproduce, but sometimes it can still be triggered.)
10. Somewhere global mouse coordinates aren't turned into local coordinates correctly. (Watch the Drag&Drop test not work unless the window is in the upper left corner of the screen.)
11. The new flipping ink implementation is buggy, it produces garbage output in some cases.
12. In the address book, there are often wide grey borders instead of the narrow black ones.
13. McCLIM seems to think that things like button panes have a maximum size equal to their preferred size. I don't agree and return the default gtk size as space-requirement :width and :height without giving a maximum or minimum size at all. Naturally, the existing demos look a little, erm, different with that.
14. Climacs doesn't draw itself until the window is resized.