mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 23 Apr '06

23 Apr '06

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.

1 0

[mcclim-cvs] CVS mcclim
by afuchs 22 Apr '06

22 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32675 Modified Files: incremental-redisplay.lisp Log Message: Back out the spatial-trees change to compute-difference-set. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/22 15:31:27 1.60 @@ -754,12 +754,12 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - (stay-tree (%make-tree-output-record-tree))) + (is-table (make-hash-table :test #'equalp))) (labels ((collect-1-was (record) (push record was) @@ -771,14 +771,12 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -829,15 +827,15 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into gone-overlap* else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into come-overlap* else collect (list k k) into come* finally (return (values come* come-overlap*)))))

1 0

[mcclim-cvs] CVS mcclim
by crhodes 21 Apr '06

21 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30320 Modified Files: commands.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/23 17:03:38 1.61 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/04/21 12:03:23 1.62 @@ -95,8 +95,9 @@ (defparameter *command-tables* (make-hash-table :test #'eq)) -(define-condition command-table-error (error) - ()) +(define-condition command-table-error (simple-error) + () + (:default-initargs :format-control "" :format-arguments nil)) (define-condition command-table-not-found (command-table-error) ())

1 0

[mcclim-cvs] CVS mcclim/Tests
by crhodes 21 Apr '06

21 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv30320/Tests Modified Files: commands.lisp Added Files: input-editing.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/03/23 17:03:40 1.3 +++ /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/04/21 12:03:23 1.4 @@ -50,3 +50,23 @@ 'removal-test-table) (command-not-present () t) (:no-error (x) (declare (ignore x)) nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; command table errors (see 27.2) +(assert (subtypep 'command-table-error 'error)) +(assert (subtypep 'command-table-not-found 'command-table-error)) +(assert (subtypep 'command-table-already-exists 'command-table-error)) +(assert (subtypep 'command-not-present 'command-table-error)) +(assert (subtypep 'command-not-accessible 'command-table-error)) +(assert (subtypep 'command-already-present 'command-table-error)) + +(let ((condition (make-condition 'command-table-error + :format-control "~A" + :format-arguments '(!)))) + (assert (find #\! (format nil "~A" condition)))) +;;; not actually required to DTRT here, but we use this form (without +;;; control and arguments) internally, so make sure that we don't +;;; error out recursively when in the debugger with one of these. +(let ((condition (make-condition 'command-not-present))) + (format nil "~A" condition)) --- /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 NONE +++ /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 1.1 (defpackage :clim-tests (:use :clim-lisp :clim)) (in-package :clim-tests) (assert (null *activation-gestures*))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26160 Modified Files: incremental-redisplay.lisp Log Message: Remove the STAY list for good from c-d-set. Agh. Save your buffers before committing. Sorry for the commits spam. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 @@ -754,7 +754,6 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is - stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) @@ -772,7 +771,8 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table)))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25992 Modified Files: incremental-redisplay.lisp Log Message: Big O changes, this time. Some more constant factors, too. * Use a spatial tree for the "stay" records and query it. Note that I said "changes", not improvements. It's 1:30 in the morning, so I'll leave the benchmarking to others. (: * Also, build the list of gone-overlap, come-overlap, come and gone records "right" the first time around, so we can just return it unmodified, without having to mapcar (list x x) over them first. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 @@ -759,7 +759,8 @@ (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp))) + (is-table (make-hash-table :test #'equalp)) + (stay-tree (%make-tree-output-record-tree))) (labels ((collect-1-was (record) (push record was) @@ -776,7 +777,8 @@ (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -827,29 +829,28 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into gone-overlap* - else collect k into gone* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into gone-overlap* + else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into come-overlap* - else collect k into come* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into come-overlap* + else collect (list k k) into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ... (values ;; erases - (loop for k in gone collect (list k k)) + gone ;; moves nil ;; draws - (loop for k in come collect (list k k)) + come ;; erase overlapping - (append (loop for k in gone-overlap collect (list k k)) - (loop for k in come-overlap collect (list k k))) + (append gone-overlap come-overlap) ;; move overlapping nil)))))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20802 Modified Files: incremental-redisplay.lisp Log Message: argh. revert the last constant-factors fold. gather-was and gather-is are fundamentally different. file under lessons learned. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 @@ -778,24 +778,38 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there and what's still there - (labels ((gather-was-and-is (record) + ;; Collect what was there + (labels ((gather-was (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) (collect-1-is record)) ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-was-and-is - (old-children record) + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) - (gather-was-and-is record))) + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; (let (gone) ;; gone = was \ is

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19230 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set further * gather-was and gather-is do the same, too. merge them. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 @@ -778,38 +778,24 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there - (labels ((gather-was (record) + ;; Collect what was there and what's still there + (labels ((gather-was-and-is (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record)) - ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds))) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-was record everywhere))))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (collect-1-is record)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record) (collect-1-is record)) ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) + (map-over-output-records-overlapping-region #'gather-was-and-is + (old-children record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record))) + (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) + (gather-was-and-is record))) ;; (let (gone) ;; gone = was \ is

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19078 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set. * now does more things in only one iteration over: * is, is-table, come, stay * was, was-table. * big-O improvements left as an exercise to the reader or evaluator. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/03/10 21:58:13 1.54 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 @@ -748,75 +748,79 @@ (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) - offset-x offset-y - old-offset-x old-offset-y) + offset-x offset-y + old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay + come (everywhere (or +everywhere+ - (pane-viewport-region (updating-output-stream record))))) - ;; Collect what was there - (labels ((gather-was (record) - (cond ((displayed-output-record-p record) - (push record was)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record was)) - ((eq :moved (output-record-dirty record)) - (push (slot-value record 'old-bounds) was)) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) + (pane-viewport-region (updating-output-stream record)))) + (was-table (make-hash-table :test #'equalp)) + (is-table (make-hash-table :test #'equalp))) + + (labels ((collect-1-was (record) + (push record was) + (push record (gethash (output-record-hash record) was-table))) + (collect-1-is (record) + (push record is) + (push record (gethash (output-record-hash record) is-table)) + ;; come = is \ was + ;; stay = is ^ was + (cond ((updating-output-record-p record) + (if (eq :clean (output-record-dirty record)) + (push record stay) + (push record come))) (t - (map-over-output-records-overlapping-region #'gather-was record everywhere)) ))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (push record is)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record is)) - ((eq :moved (output-record-dirty record)) - (push record is)) - (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record)) + (let ((q (gethash (output-record-hash record) was-table))) + (if (some #'(lambda (x) (output-record-equal record x)) q) + (push record stay) + (push record come))))))) + ;; Collect what was there + (labels ((gather-was (record) + (cond ((displayed-output-record-p record) + (collect-1-was record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-is record)) + ((eq :moved (output-record-dirty record)) + (collect-1-is record)) + (t + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; - (let ((was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - gone - stay - come) - (loop for w in was do (push w (gethash (output-record-hash w) was-table))) - (loop for i in is do (push i (gethash (output-record-hash i) is-table))) + (let (gone) ;; gone = was \ is (loop for w in was do - (cond ((updating-output-record-p w) - (unless (eq :clean (output-record-dirty w)) - (push (old-children w) gone))) - (t - (let ((q (gethash (output-record-hash w) is-table))) - (unless (some #'(lambda (x) (output-record-equal w x)) q) - (push w gone)))))) - ;; come = is \ was - ;; stay = is ^ was - (loop for i in is do - (cond ((updating-output-record-p i) - (if (eq :clean (output-record-dirty i)) - (push i stay) - (push i come))) - (t - (let ((q (gethash (output-record-hash i) was-table))) - (if (some #'(lambda (x) (output-record-equal i x)) q) - (push i stay) - (push i come)))))) + (cond ((updating-output-record-p w) + (unless (eq :clean (output-record-dirty w)) + (push (old-children w) gone))) + (t + (let ((q (gethash (output-record-hash w) is-table))) + (unless (some #'(lambda (x) (output-record-equal w x)) q) + (push w gone)))))) ;; Now we essentially want 'gone', 'stay', 'come' (let ((gone-overlap nil) (come-overlap nil)) @@ -825,14 +829,14 @@ (loop for k in gone if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into gone-overlap* + collect k into gone-overlap* else collect k into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into come-overlap* + collect k into come-overlap* else collect k into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ...

1 0

[mcclim-cvs] CVS mcclim/Examples
by crhodes 19 Apr '06

19 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv28012/Examples Modified Files: text-size-test.lisp Log Message: Add text-bounding-rectangle* mode to text-size-test --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:58 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/19 11:43:31 1.2 @@ -37,6 +37,11 @@ (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) + (rectangle + (with-radio-box () + (radio-box-current-selection + (make-pane 'toggle-button :label "Text-Size" :id :text-size)) + (make-pane 'toggle-button :label "Text-Bounding-Rectangle" :id :text-bounding-rectangle))) (size (make-pane 'slider :orientation :horizontal @@ -49,7 +54,8 @@ (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) - (labelling (:label "Face") face)) + (labelling (:label "Face") face) + (labelling (:label "Rectangle") rectangle)) (labelling (:label "Size") size) canvas)))) @@ -62,6 +68,7 @@ (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) + (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size))) (multiple-value-bind (width height final-x final-y baseline) @@ -78,16 +85,26 @@ ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) - (draw-rectangle* stream - x1 y1 - (+ x1 width) (+ y1 height) - :ink +red+ - :filled nil) - (draw-rectangle* stream - x1 y1 - (+ x1 final-x) (+ y1 final-y) - :ink +blue+ - :filled nil))))) + (ecase rectangle + ((:text-size) + (draw-rectangle* stream + x1 y1 + (+ x1 width) (+ y1 height) + :ink +red+ + :filled nil) + (draw-rectangle* stream + x1 y1 + (+ x1 final-x) (+ y1 final-y) + :ink +blue+ + :filled nil)) + ((:text-bounding-rectangle) + (multiple-value-bind (left top right bottom) + (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style) + (draw-rectangle* stream + (+ x1 left) (+ y1 baseline top) + (+ x1 right) (+ y1 baseline bottom) + :ink +purple+ + :filled nil)))))))) (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs