Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv23372 Modified Files: clim-fix.lisp event.lisp gtk-ffi.lisp medium.lisp port.lisp Log Message: Low-flicker drawing: Double-buffer everything. * clim-fix.lisp (HANDLE-REPAINT, HIGHLIGHT-OUTPUT-RECORD-RECTANGLE): Use FORCE-OUTPUT on the SHEET instead of MEDIUM-FORCE-OUTPUT. * event.lisp (EXPOSE-HANDLER): If the mirror has a valid double buffering pixmap, has just blit the exposed rectangle to screen. Else, this must be the first redraw after initialization (A) or resize (B), so enqueue a window repaint event to get things going. For case A, clear the actual widget, since the frontend assumes mirrors to be filled with the background color if it never handles repaints on it. In case B, mark the pixmap as complete again. * gtk-ffi.lisp (gdk_window_invalidate_rect): New declaration. * medium.lisp (SYNC-SHEET): Mark the medium as dirty. (MEDIUM-FINISH-OUTPUT): Call medium-force-output after flushing the cairo surface. (MEDIUM-FORCE-OUTPUT): Remove the medium from the dirty table and invalidate the mirror. (INVALIDATE-MIRROR): For widget mirrors (with a double buffering pixmap), send an expose event. * port.lisp (*DOUBLE-BUFFERING-P*): New variable. (PORT): New slot DIRTY-MEDIUMS. (WIDGET-MIRROR): New slots PORT, BUFFERING-PIXMAP, BUFFERING-PIXMAP-P. (DRAWABLE-MIRROR): Additional accessor for the drawable slot, called MIRROR-REAL-DRAWABLE. ((MIRROR-REAL-DRAWABLE WIDGET-MIRROR)): Return the gdk window. (MIRROR-DRAWABLE): New method. Return or install the double buffering pixmap if *DOUBLE-BUFFERING-P* is enabled. Else return the real drawable. (REALIZE-WINDOW-MIRROR, REALIZE-MIRROR): Set the mirror's PORT slot. ((DESTROY-MIRROR MIRRORED-SHEET-MIXIN)): Free the double buffering pixmap. (RESET-MEDIUMS): Create a new double buffering pixmap for current size, copy over the old content, mark the pixmap as incomplete, and free the old one. (PORT-SET-MIRROR-REGION): Call RESET-MEDIUMS only after the resize has happened. (PORT-SET-MIRROR-TRANSFORMATION): No need to call RESET-MEDIUMS. (PORT-FORCE-OUTPUT): Call MEDIUM-FORCE-OUTPUT for all dirty mediums. Don't exit on X errors: * gtk-ffi.lisp (_gdk_error_warnings, _gdk_error_code, XGetErrorText): New declarations. * event.lisp (DRIBBLE-X-ERRORS): New function. (GTK-MAIN-ITERATION): Call DRIBBLE-X-ERRORS. * port.lisp (initialize-instance): Turn off `gdk-error-warnings', thereby disabling the GTk+'s "exit on error" behaviour. (PORT-FORCE-OUTPUT): Call DRIBBLE-X-ERRORS. Implement the weird pointer tracking code CLIM-CLX has: * port.lisp (PORT): New slot POINTER-GRAB-SHEET. (PORT-GRAB-POINTER): Set POINTER-GRAB-SHEET. (PORT-UNGRAB-POINTER): Clear POINTER-GRAB-SHEET if it is equal to the ungrabbing sheet. (DISTRIBUTE-EVENT :AROUND): Send events to the grabbing sheet no matter what. Misc: * event.lisp (ENTER-HANDLER): Set PORT-POINTER-SHEET manually, fixing a problem with the Drag and Drop demo. * medium.lisp (SYNC-TRANSFORMATION): Error out on invalid transformation -before- installing them into the cairo context. ((SYNC-INK FLIPPING-INK)): Removed unused binding of allocation size. * port.lisp (PORT-MIRROR-WIDTH, PORT-MIRROR-HEIGHT): Implemented. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/05/02 13:02:09 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/11/05 17:22:23 1.5 @@ -36,8 +36,7 @@ ;; multiple times and looks like crap. This fixes it: (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) - (call-next-method s r))) - (medium-force-output m))) + (call-next-method s r))))) ;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid ;; anti-aliasing (and follow-up output artifacts) @@ -58,4 +57,5 @@ ;; FIXME: repaint the hit detection rectangle. It could be ;; bigger than ;; the bounding rectangle. - (repaint-sheet stream record)))))) + (repaint-sheet stream record))) + (force-output stream)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/13 19:37:29 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 17:22:23 1.9 @@ -85,6 +85,15 @@ (pop (events-head port)) (car c))))) +(defun dribble-x-errors () + (unless (zerop *-gdk-error-code*) + (warn "Ignoring X error ~D: ~A" + *-gdk-error-code* + (cffi:with-foreign-pointer-as-string (buf 64) + #-(or win32 windows mswindows) + (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) + (setf *-gdk-error-code* 0))) + ;; thread-safe entry function (defun gtk-main-iteration (port &optional block) (with-gtk () @@ -92,7 +101,8 @@ (if block (gtk_main_iteration_do 1) (while (plusp (gtk_events_pending)) - (gtk_main_iteration_do 0)))))) + (gtk_main_iteration_do 0)))) + (dribble-x-errors))) (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) @@ -128,13 +138,29 @@ (define-signal noop-handler (widget event)) (define-signal expose-handler (widget event) - (enqueue - (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) - (gdk_window_clear_area (gtkwidget-gdkwindow widget) x y width height) - (make-instance 'window-repaint-event - :timestamp (get-internal-real-time) - :sheet (widget->sheet widget *port*) - :region (make-rectangle* x y (+ x width) (+ y height)))))) + (let* ((sheet (widget->sheet widget *port*)) + (mirror (climi::port-lookup-mirror *port* sheet))) + (unless + ;; fixme: this shouldn't happen + (typep mirror 'drawable-mirror) + (if (buffering-pixmap-dirty-p mirror) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (if (mirror-buffering-pixmap mirror) + (setf (buffering-pixmap-dirty-p mirror) nil) + (gdk_window_clear_area (gtkwidget-gdkwindow widget) + x y + width height)) + (enqueue + (make-instance 'window-repaint-event + :timestamp (get-internal-real-time) + :sheet (widget->sheet widget *port*) + :region (make-rectangle* x y (+ x width) (+ y height))))) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (let* ((from (mirror-buffering-pixmap mirror)) + (to (gtkwidget-gdkwindow (mirror-widget mirror))) + (gc (gdk_gc_new to))) + (gdk_draw_drawable to gc from x y x y width height) + (gdk_gc_unref gc))))))) (defun gdkmodifiertype->modifier-state (state) (logior @@ -246,6 +272,11 @@ (define-signal enter-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root) event gdkeventcrossing) + ;; The frontend sets p-p-s for us, but apparently that sometimes + ;; happens too late, leaving NIL in the slot. Test case is the Drag and + ;; Drop demo. (Even weirder: Starting it from demodemo for a second time + ;; makes the problem go away, only the first invocation has this problem.) + (setf (climi::port-pointer-sheet *port*) (widget->sheet widget *port*)) (enqueue (make-instance 'pointer-enter-event :pointer 0 --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/13 19:37:29 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:22:23 1.8 @@ -120,6 +120,19 @@ (gdk_threads_leave))))) +;;; Error handling: + +(cffi:defcvar "_gdk_error_warnings" :int) +(cffi:defcvar "_gdk_error_code" :int) + +(cffi:defcfun "XGetErrorText" + :void + (display :pointer) + (code :int) + (buf :pointer) + (length :int)) + + ;;; GROVELME ;; must be a separate structure definition in order for padding on AMD64 @@ -730,6 +743,12 @@ (width :int) (height :int)) +(defcfun "gdk_window_invalidate_rect" + :void + (window :pointer) + (rect :pointer) + (childrenp :int)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/06/10 10:08:49 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 17:22:23 1.9 @@ -75,6 +75,8 @@ (sheet-region (medium-sheet medium))))))) (defun sync-sheet (medium) + (when (medium-sheet medium) ;ignore the metrik-medium + (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-cairo-medium (medium) @@ -121,6 +123,10 @@ (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) + ;; Make sure not to hand transformations to cairo that it won't + ;; like, since debugging gets ugly once a cairo context goes + ;; into an error state: + (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) @@ -238,21 +244,18 @@ (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* ((region (climi::sheet-mirror-region (medium-sheet medium))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap - (or (flipping-pixmap medium) - (setf (flipping-pixmap medium) - (gdk_pixmap_new drawable width height -1))))) - (setf (cr medium) (gdk_cairo_create pixmap)) - (setf (flipping-region medium) region) - (cairo_paint (cr medium)) - (sync-transformation medium) - (sync-ink medium +white+))))) + (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap + (or (flipping-pixmap medium) + (setf (flipping-pixmap medium) + (gdk_pixmap_new drawable width height -1))))) + (setf (cr medium) (gdk_cairo_create pixmap)) + (setf (flipping-region medium) region) + (cairo_paint (cr medium)) + (sync-transformation medium) + (sync-ink medium +white+)))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) @@ -639,12 +642,30 @@ (defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))))) + (medium-force-output medium)) (defmethod medium-force-output ((medium gtkairo-medium)) + (remhash medium (dirty-mediums (port medium))) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))) + (invalidate-mirror (medium-mirror medium) (medium-sheet medium))))) + +(defmethod invalidate-mirror ((mirror drawable-mirror) sheet) + (declare (ignore sheet))) + +(defmethod invalidate-mirror ((mirror widget-mirror) sheet) + (let* ((drawable (mirror-drawable mirror)) + (real-drawable (mirror-real-drawable mirror))) + (unless (cffi:pointer-eq drawable real-drawable) + (let* ((region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region)))) + (cffi:with-foreign-object (r 'gdkrectangle) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'width) width) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'height) height) + (gdk_window_invalidate_rect real-drawable r 0)))))) (defmethod medium-beep ((medium gtkairo-medium)) ;; fixme: visual beep? --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/13 19:37:29 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 17:22:23 1.5 @@ -47,7 +47,9 @@ (events-head :accessor events-head) (events-tail :accessor events-tail) (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) - (metrik-medium :accessor metrik-medium))) + (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) + (metrik-medium :accessor metrik-medium) + (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) @@ -72,7 +74,8 @@ (slot-value port 'climi::frame-managers)) (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) - (gdk_threads_init)) + (gdk_threads_init) + (setf *-gdk-error-warnings* 0)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten @@ -106,8 +109,13 @@ (region :initform nil :accessor mirror-region))) (defclass widget-mirror (mirror) - ((widget :initarg :widget :accessor mirror-widget) - (mediums :initform '() :accessor mirror-mediums))) + ((port :initarg :port :accessor mirror-port) + (widget :initarg :widget :accessor mirror-widget) + (mediums :initform '() :accessor mirror-mediums) + (buffering-pixmap-dirty-p + :initform t + :accessor buffering-pixmap-dirty-p) + (buffering-pixmap :initform nil :accessor mirror-buffering-pixmap))) (defclass window-mirror (widget-mirror) ((window :initarg :window :accessor mirror-window))) @@ -116,12 +124,42 @@ ((fixed :initarg :fixed :accessor mirror-fixed))) (defclass drawable-mirror (mirror) - ((drawable :initarg :drawable :accessor mirror-drawable) + ((drawable :initarg :drawable + :accessor mirror-drawable + :accessor mirror-real-drawable) (mediums :initform '() :accessor mirror-mediums))) -(defmethod mirror-drawable ((mirror widget-mirror)) +(defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) +(defvar *double-buffering-p* t) + +(defparameter *old-frontend-size-hack* t) + +(defmethod mirror-drawable ((mirror widget-mirror)) + (if *double-buffering-p* + (or (mirror-buffering-pixmap mirror) + (setf (mirror-buffering-pixmap mirror) + (let* ((*old-frontend-size-hack* nil) + (window (mirror-real-drawable mirror)) + (region (climi::sheet-mirror-region + (climi::port-lookup-sheet + (mirror-port mirror) + mirror))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap (gdk_pixmap_new window width height -1)) + (cr (gdk_cairo_create pixmap))) + (cairo_set_source_rgba cr + 1.0d0 + 1.0d0 + 1.0d0 + 1.0d0) + (cairo_paint cr) + (cairo_destroy cr) + pixmap))) + (mirror-real-drawable mirror))) + (defun widget->sheet (widget port) (gethash (cffi:pointer-address widget) (widgets->sheets port))) @@ -160,7 +198,10 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'window-mirror :window window :widget widget))) + (mirror (make-instance 'window-mirror + :port port + :window window + :widget widget))) (gtk_window_set_title window (frame-pretty-name (pane-frame sheet))) (setf (widget->sheet widget port) sheet) (setf (widget->sheet window port) sheet) @@ -216,7 +257,7 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'widget-mirror :widget widget))) + (mirror (make-instance 'widget-mirror :port port :widget widget))) (setf (widget->sheet widget port) sheet) ;; Das machen wir uns mal einfach und geben jedem Widget sein eigenes ;; Fenster, dann haben wir naemlich das Koordinatensystem und Clipping @@ -266,7 +307,10 @@ (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror - (make-instance 'native-widget-mirror :fixed fixed :widget widget))) + (make-instance 'native-widget-mirror + :port port + :fixed fixed + :widget widget))) (setf (widget->sheet fixed port) sheet) (setf (widget->sheet widget port) sheet) (gtk_fixed_set_has_window fixed 1) @@ -376,6 +420,8 @@ (let ((mirror (climi::port-lookup-mirror port sheet))) (destroy-mediums mirror) (gtk_widget_destroy (mirror-widget mirror)) + (when (mirror-buffering-pixmap mirror) + (gdk_drawable_unref (mirror-drawable mirror))) (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) @@ -408,15 +454,25 @@ (defun reset-mediums (mirror) (dolist (medium (mirror-mediums mirror)) - (setf (cr medium) nil))) + (setf (cr medium) nil)) + (when (mirror-buffering-pixmap mirror) + (let* ((old (mirror-buffering-pixmap mirror)) + (new (progn + (setf (mirror-buffering-pixmap mirror) nil) + (mirror-drawable mirror))) + (gc (gdk_gc_new new))) + (gdk_draw_drawable new gc old 0 0 0 0 -1 -1) + (gdk_gc_unref gc) + (gdk_drawable_unref old)) + (setf (buffering-pixmap-dirty-p mirror) t))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror window-mirror) mirror-region) (with-gtk () - (reset-mediums mirror) (gtk_window_resize (mirror-window mirror) (floor (bounding-rectangle-max-x mirror-region)) (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror) ;; Nanu, ohne die Geometrie hier zu korrigieren kann das Fenster nur ;; vergroessert, nicht aber wieder verkleinert werden. (cffi:with-foreign-object (geometry 'gdkgeometry) @@ -432,11 +488,11 @@ (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)))) + (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror)) (setf (mirror-region mirror) mirror-region))) (defmethod port-set-mirror-region @@ -452,7 +508,8 @@ (with-gtk () (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_window_move (mirror-window mirror) (floor x) (floor y))))) + (gtk_window_move (mirror-window mirror) (floor x) (floor y))) + (reset-mediums mirror))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror mirror) mirror-transformation) @@ -578,10 +635,28 @@ (error "port-string-width called, what now?")) (defmethod port-mirror-width ((port gtkairo-port) sheet) - (error "port-mirror-width called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'width)))) (defmethod port-mirror-height ((port gtkairo-port) sheet) - (error "port-mirror-height called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'height)))) + +(defmethod port-mirror-width ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-width sheet)) + +(defmethod port-mirror-height ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-height sheet)) (defmethod graft ((port gtkairo-port)) (first (climi::port-grafts port))) @@ -655,11 +730,15 @@ (defmethod port-force-output ((port gtkairo-port)) (with-gtk () + (loop + for medium being each hash-key in (dirty-mediums port) + do (medium-force-output medium)) (gdk_display_flush (gdk_display_get_default)) ;; Don't know whether p-f-o is actually meant to XSync, which is ;; what gdk_flush does. But it seems useful to have _some_ function ;; for this, so let's use p-f-o until we find a better one. - (gdk_flush))) + (gdk_flush) + (dribble-x-errors))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet) @@ -680,15 +759,21 @@ ;;; (tr :timeout!) ;;; (with-gtk () ;;; (gdk_pointer_ungrab GDK_CURRENT_TIME)))) - (zerop status)))) + (when (zerop status) + (setf (pointer-grab-sheet port) sheet))))) (defmethod port-ungrab-pointer ((port gtkairo-port) pointer sheet) (declare (ignore pointer sheet)) (with-gtk () - (gdk_pointer_ungrab GDK_CURRENT_TIME))) + (when (eq (pointer-grab-sheet port) sheet) + (gdk_pointer_ungrab GDK_CURRENT_TIME) + (setf (pointer-grab-sheet port) nil)))) (defmethod distribute-event :around ((port gtkairo-port) event) - (call-next-method)) + (let ((grab-sheet (pointer-grab-sheet port))) + (if grab-sheet + (queue-event grab-sheet event) + (call-next-method)))) (defmethod set-sheet-pointer-cursor ((port gtkairo-port) sheet cursor) ())