January 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/presentations.lisp
by tmoore＠common-lisp.net 14 Jan '05

14 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv7897 Modified Files: presentations.lisp Log Message: Change ROUND-COORDINATES back to the definition that rounds up at half pixel boundaries. When I made the previous change I didn't realize that X coordinates are at pixel centers. Date: Fri Jan 14 13:43:23 2005 Author: tmoore Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.69 mcclim/presentations.lisp:1.70 --- mcclim/presentations.lisp:1.69 Tue Jan 11 14:02:19 2005 +++ mcclim/presentations.lisp Fri Jan 14 13:43:23 2005 @@ -45,6 +45,16 @@ (presentation-mixin standard-sequence-output-record) ()) +(defvar *print-presentation-verbose* nil) + +(defmethod print-object ((self standard-presentation) stream) + (print-unreadable-object (self stream :type t :identity t) + (with-bounding-rectangle* (x1 y1 x2 y2) + self + (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self)) + (when *print-presentation-verbose* + (format stream " ~S" (presentation-object self)))))) + (defgeneric ptype-specializer (type) (:documentation "The specializer to use for this type in a presentation method lambda list")) @@ -1757,7 +1767,7 @@ (frame *application-frame*) event modifier-state button) (find-innermost-presentation-match input-context - (stream-output-history window) + top-record frame window x y @@ -1789,6 +1799,8 @@ x y) (when ptype (funcall (cdr context) object ptype event options))))))) + +(defvar *input-context*) (defun throw-object-ptype (object type &key (input-context *input-context*) sheet)

1 0

[mcclim-cvs] CVS update: mcclim/stream-input.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23180 Modified Files: stream-input.lisp Log Message: Save the last character returned by stream-read-gesture for unreading Date: Tue Jan 11 16:33:32 2005 Author: tmoore Index: mcclim/stream-input.lisp diff -u mcclim/stream-input.lisp:1.40 mcclim/stream-input.lisp:1.41 --- mcclim/stream-input.lisp:1.40 Thu Oct 14 08:30:11 2004 +++ mcclim/stream-input.lisp Tue Jan 11 16:33:32 2005 @@ -123,7 +123,11 @@ (defclass standard-extended-input-stream (extended-input-stream) ((pointer) - (cursor :initarg :text-cursor))) + (cursor :initarg :text-cursor) + (last-gesture :accessor last-gesture :initform nil + :documentation "Holds the last gesture returned by + stream-read-gesture (not peek-p), untransformed, so it can easily be + unread."))) (defvar *input-wait-test* nil) (defvar *input-wait-handler* nil) @@ -254,7 +258,8 @@ ;; An event should be in the stream buffer now. (when (handle-non-stream-event buffer) (go wait-for-char)) - (let ((gesture (convert-to-gesture (pop-gesture buffer peek-p)))) + (let* ((raw-gesture (pop-gesture buffer peek-p)) + (gesture (convert-to-gesture raw-gesture))) ;; Sometimes key press events get generated with a key code for ;; which there is no keysym. This seems to happen on my machine ;; when keys are hit rapidly in succession. I'm not sure if this is @@ -274,7 +279,8 @@ thereis (event-matches-gesture-name-p gesture gesture-name)) (signal 'accelerator-gesture :event gesture)) - (t (return-from stream-read-gesture gesture)))) + (t (setf (last-gesture stream) raw-gesture) + (return-from stream-read-gesture gesture)))) (go wait-for-char))))) @@ -315,8 +321,12 @@ (defmethod stream-unread-gesture ((stream standard-extended-input-stream) gesture) + (declare (ignore gesture)) (with-encapsulating-stream (estream stream) - (repush-gesture gesture (stream-input-buffer estream)))) + (let ((gesture (last-gesture stream))) + (when gesture + (setf (last-gesture stream) nil) + (repush-gesture gesture (stream-input-buffer estream)))))) ;;; Standard stream methods on standard-extended-input-stream. Ignore any ;;; pointer gestures in the input buffer.

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/menu-choose.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv20221/Experimental Modified Files: menu-choose.lisp Log Message: Remove some debugging code Date: Tue Jan 11 15:39:03 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.14 mcclim/Experimental/menu-choose.lisp:1.15 --- mcclim/Experimental/menu-choose.lisp:1.14 Tue Jan 11 14:14:21 2005 +++ mcclim/Experimental/menu-choose.lisp Tue Jan 11 15:39:02 2005 @@ -273,9 +273,6 @@ (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) (:presentation (&key presentation) - (format *trace-output* "type:~S presentation:~S~%" - presentation-type - presentation) (setq exit-menu t)) (:pointer-button-release (&key event x y) ; Pointer clicked outside menu? ; Close the menu.

1 0

[mcclim-cvs] CVS update: mcclim/Examples/dragndrop.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv16352/Examples Added Files: dragndrop.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:41 2005 Author: tmoore

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp mcclim/Backends/CLX/port.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv16352/Backends/CLX Modified Files: medium.lisp port.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:37 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.63 mcclim/Backends/CLX/medium.lisp:1.64 --- mcclim/Backends/CLX/medium.lisp:1.63 Fri Apr 23 21:29:49 2004 +++ mcclim/Backends/CLX/medium.lisp Tue Jan 11 14:35:33 2005 @@ -31,7 +31,6 @@ ;; cache. ;; --GB - ;;; CLX-MEDIUM class (defclass clx-medium (basic-medium) @@ -293,20 +292,16 @@ (error "Sorry, not yet implemented.")) ;; Bah! (typecase design - (climi::indexed-pattern - (let ((gc (design-gcontext medium design))) - (setf (xlib:gcontext-ts-x gc) (round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-ts-y gc) (round (nth-value 1 (transform-position transformation 0 0))) - (xlib:gcontext-clip-x gc)(round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-clip-y gc)(round (nth-value 1 (transform-position transformation 0 0)))) - gc)) - (climi::rectangular-tile - (let ((gc (design-gcontext medium design))) - (setf (xlib:gcontext-ts-x gc) (round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-ts-y gc) (round (nth-value 1 (transform-position transformation 0 0))) - (xlib:gcontext-clip-x gc)(round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-clip-y gc)(round (nth-value 1 (transform-position transformation 0 0)))) - gc)) + ((or climi::indexed-pattern climi::rectangular-tile) + (multiple-value-bind (tx ty) + (transform-position transformation 0 0) + (let ((gc-x (round-coordinate tx)) + (gc-y (round-coordinate ty)) + (gc (design-gcontext medium design))) + (setf (xlib:gcontext-ts-x gc) gc-x + (xlib:gcontext-ts-y gc) gc-y + (xlib:gcontext-clip-x gc) gc-x + (xlib:gcontext-clip-y gc) gc-y)))) (t (error "You lost, we not yet implemented transforming an ~S." (type-of ink)))))) @@ -327,15 +322,18 @@ ; and kill them at the source... #-nil (defun clipping-region->rect-seq (clipping-region) - (loop for region in (nreverse (mapcan - (lambda (v) (unless (eq v +nowhere+) (list v))) - (region-set-regions clipping-region - :normalize :y-banding))) - as rectangle = (bounding-rectangle region) - nconcing (list (round (rectangle-min-x rectangle)) - (round (rectangle-min-y rectangle)) - (round (rectangle-width rectangle)) - (round (rectangle-height rectangle))))) + (loop + for region in (nreverse (mapcan + (lambda (v) (unless (eq v +nowhere+) (list v))) + (region-set-regions clipping-region + :normalize :y-banding))) + as rectangle = (bounding-rectangle region) + for clip-x = (round-coordinate (rectangle-min-x rectangle)) + for clip-y = (round-coordinate (rectangle-min-y rectangle)) + nconcing (list clip-x + clip-y + (- (round-coordinate (rectangle-max-x rectangle)) clip-x) + (- (round-coordinate (rectangle-max-y rectangle)) clip-y)))) (defmacro with-clx-graphics ((medium) &body body) `(let* ((port (port ,medium)) @@ -355,6 +353,8 @@ ;;; Pixmaps +;;; width and height arguments should be integers, but we'll leave the calls +;;; to round in for now. (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable clx-medium) to-x to-y) @@ -364,9 +364,10 @@ to-x to-y) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (sheet-direct-mirror (medium-sheet to-drawable)) - (round to-x) (round to-y))))) + (round-coordinate to-x) (round-coordinate to-y))))) (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) @@ -374,9 +375,10 @@ from-x from-y) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (pixmap-mirror to-drawable) - (round to-x) (round to-y)))) + (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable clx-medium) to-x to-y) @@ -384,17 +386,19 @@ to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext to-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (sheet-direct-mirror (medium-sheet to-drawable)) - (round to-x) (round to-y)))) + (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (pixmap-mirror to-drawable) - (round to-x) (round to-y))) + (round-coordinate to-x) (round-coordinate to-y))) ;;; Medium-specific Drawing Functions @@ -405,19 +409,23 @@ x y) (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) - (let ((x (floor x)) - (y (floor y))) + (let ((x (round-coordinate x)) + (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y)))) (t - (let* ((radius (round (line-style-thickness line-style) 2)) - (diameter (* radius 2))) - (let ((x (floor (- x radius))) - (y (floor (- y radius)))) - (when (and (typep x '(signed-byte 16)) - (typep y '(signed-byte 16))) - (xlib:draw-arc mirror gc x y diameter diameter 0 (* 2 pi) t))))) )))) + (let* ((radius (/ (line-style-thickness line-style) 2)) + (min-x (round-coordinate (- x radius))) + (min-y (round-coordinate (- y radius))) + (max-x (round-coordinate (+ x radius))) + (max-y (round-coordinate (+ y radius)))) + (when (and (typep min-x '(signed-byte 16)) + (typep min-y '(signed-byte 16))) + (xlib:draw-arc mirror gc min-x min-y + (- max-x min-x) (- max-y min-y) + 0 (* 2 pi) t)))))))) + (defmethod medium-draw-points* ((medium clx-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation @@ -426,33 +434,23 @@ (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) (do-sequence ((x y) coord-seq) - (let ((x (floor x)) - (y (floor y))) + (let ((x (round-coordinate x)) + (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y))))) (t - (let* ((radius (round (line-style-thickness line-style) 2)) - (diameter (* radius 2))) + (let ((radius (/ (line-style-thickness line-style) 2))) (do-sequence ((x y) coord-seq) - (let ((x (floor (- x radius))) - (y (floor (- y radius)))) - (when (and (typep x '(signed-byte 16)) - (typep y '(signed-byte 16))) - (xlib:draw-arc mirror gc x y diameter diameter 0 (* 2 pi) t)))))) )))) - -(declaim (inline round-coordinate)) -(defun round-coordinate (x) - "Function used for rounding coordinates." - ;; We use "mercantile rounding", instead of the CL round to nearest - ;; even number, when in doubt. - ;; - ;; Reason: As the CLIM drawing model is specified, you quite often - ;; want to operate with coordinates, which are multiples of 1/2. - ;; Using CL:ROUND gives you "random" results. Using "mercantile - ;; rounding" gives you consistent results. - ;; - (floor (+ x .5))) + (let ((min-x (round-coordinate (- x radius))) + (min-y (round-coordinate (- y radius))) + (max-x (round-coordinate (+ x radius))) + (max-y (round-coordinate (+ y radius)))) + (when (and (typep min-x '(signed-byte 16)) + (typep min-y '(signed-byte 16))) + (xlib:draw-arc mirror gc min-x min-y + (- max-x min-x) (- max-y min-y) + 0 (* 2 pi) t)))))))))) (defmethod medium-draw-line* ((medium clx-medium) x1 y1 x2 y2) (let ((tr (sheet-native-transformation (medium-sheet medium)))) @@ -516,6 +514,8 @@ (with-transformed-position (tr left top) (with-transformed-position (tr right bottom) (with-clx-graphics (medium) + #+nil (when (typep mirror 'xlib:pixmap) + (break)) (if (< right left) (rotatef left right)) (if (< bottom top) @@ -561,16 +561,23 @@ (defmethod medium-draw-rectangles* ((medium clx-medium) position-seq filled) (assert (evenp (length position-seq))) - (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) + (with-transformed-positions ((sheet-native-transformation + (medium-sheet medium)) position-seq) (with-clx-graphics (medium) - (loop for (left top right bottom) on position-seq by #'cddddr - nconcing (list (round left) (round top) - (round (- right left)) (round (- bottom top))) into points - finally (xlib:draw-rectangles mirror gc points filled))))) + (loop + for (left top right bottom) on position-seq by #'cddddr + for min-x = (round-coordinate left) + for max-x = (round-coordinate right) + for min-y = (round-coordinate top) + for max-y = (round-coordinate bottom) + nconcing (list min-x min-y (- max-x min-x) (- min-y max-y)) into points + finally (xlib:draw-rectangles mirror gc points filled))))) +;;; Round the parameters of the ellipse so that it occupies the expected pixels (defmethod medium-draw-ellipse* ((medium clx-medium) center-x center-y - radius-1-dx radius-1-dy radius-2-dx radius-2-dy + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy start-angle end-angle filled) (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "MEDIUM-DRAW-ELLIPSE* not yet implemented for non axis-aligned ellipses.")) @@ -581,25 +588,37 @@ (+ (* pi 2) arc-angle) arc-angle))) (with-clx-graphics (medium) - (let ((radius-dx (abs (+ radius-1-dx radius-2-dx))) - (radius-dy (abs (+ radius-1-dy radius-2-dy)))) + (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) + (radius-dy (abs (+ radius-1-dy radius-2-dy))) + (min-x (round-coordinate (- center-x radius-dx))) + (min-y (round-coordinate (- center-y radius-dy))) + (max-x (round-coordinate (+ center-x radius-dx))) + (max-y (round-coordinate (+ center-y radius-dy)))) + #+nil (when (typep mirror 'xlib:pixmap) + (break)) (xlib:draw-arc mirror gc - (round (- center-x radius-dx)) (round (- center-y radius-dy)) - (round (* radius-dx 2)) (round (* radius-dy 2)) + min-x min-y (- max-x min-x) (- max-y min-y) (mod start-angle (* 2 pi)) arc-angle filled)))))) -(defmethod medium-draw-circle* ((medium clx-medium) center-x center-y radius start-angle end-angle filled) - (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) +(defmethod medium-draw-circle* ((medium clx-medium) + center-x center-y radius start-angle end-angle + filled) + (with-transformed-position ((sheet-native-transformation (medium-sheet + medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) (arc-angle (if (< end-angle 0) (+ (* pi 2) arc-angle) - arc-angle))) + arc-angle)) + (min-x (round-coordinate (- center-x radius))) + (min-y (round-coordinate (- center-y radius))) + (max-x (round-coordinate (+ center-x radius))) + (max-y (round-coordinate (+ center-y radius)))) (with-clx-graphics (medium) (xlib:draw-arc mirror gc - (round (- center-x radius)) (round (- center-y radius)) - radius radius + min-x min-y + (- max-x min-x) (- min-y max-y) start-angle arc-angle filled))))) @@ -932,7 +951,8 @@ (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) - (xlib:draw-glyph mirror gc (round x) (round y) element + (xlib:draw-glyph mirror gc (round-coordinate x) (round-coordinate y) + element :size 16 :translate #'translate)))) @@ -946,9 +966,13 @@ (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) - (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) - :x (round (min left right)) :y (round (min bottom top)) - :width (round (abs (- right left))) :height (round (abs (- bottom top))))) + (let ((min-x (round-coordinate (min left right))) + (min-y (round-coordinate (min top bottom))) + (max-x (round-coordinate (max left right))) + (max-y (round-coordinate (max top bottom)))) + (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) + :x min-x :y min-y + :width (- max-x min-x) :height (- max-y min-y)))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium)))) Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.102 mcclim/Backends/CLX/port.lisp:1.103 --- mcclim/Backends/CLX/port.lisp:1.102 Sun Jan 2 06:29:03 2005 +++ mcclim/Backends/CLX/port.lisp Tue Jan 11 14:35:33 2005 @@ -23,6 +23,21 @@ (in-package :clim-clx) +(declaim (inline round-coordinate)) +(defun round-coordinate (x) + "Function used for rounding coordinates." + ;; We use "mercantile rounding", instead of the CL round to nearest + ;; even number, when in doubt. + ;; + ;; Reason: As the CLIM drawing model is specified, you quite often + ;; want to operate with coordinates, which are multiples of 1/2. + ;; Using CL:ROUND gives you "random" results. Using "mercantile + ;; rounding" gives you consistent results. + ;; + ;; For values at .5 we round down in order to be consistant with + ;; the CLIM and CLX definitions for pixel coverage of shapes. + (ceiling (- x .5))) + ;;; CLX-PORT class (defclass clx-pointer (pointer) @@ -1173,11 +1188,18 @@ +pointer-wheel-down+) (t 0))) +#+nil (defmethod pointer-modifier-state ((pointer clx-pointer)) (multiple-value-bind (x y same-screen-p child mask) (xlib:query-pointer (clx-port-window (port pointer))) (declare (ignore x y same-screen-p child)) (clim-xcommon:x-event-state-modifiers (port pointer) mask))) + +(defmethod port-modifier-state ((port clx-port)) + (multiple-value-bind (x y same-screen-p child mask) + (xlib:query-pointer (clx-port-window port)) + (declare (ignore x y same-screen-p child)) + (clim-xcommon:x-event-state-modifiers port mask))) ;;; XXX Should we rely on port-pointer-sheet being correct? -- moore (defmethod synthesize-pointer-motion-event ((pointer clx-pointer))

1 0

[mcclim-cvs] CVS update: mcclim/graphics.lisp mcclim/incremental-redisplay.lisp mcclim/package.lisp mcclim/pointer-tracking.lisp mcclim/sheets.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv16352 Modified Files: graphics.lisp incremental-redisplay.lisp package.lisp pointer-tracking.lisp sheets.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:19 2005 Author: tmoore Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.48 mcclim/graphics.lisp:1.49 --- mcclim/graphics.lisp:1.48 Mon Mar 1 13:52:29 2004 +++ mcclim/graphics.lisp Tue Jan 11 14:35:18 2005 @@ -664,10 +664,12 @@ (setf (%sheet-medium ,sheet) old-medium));is sheet a sheet-with-medium-mixin? --GB pixmap)) -; This seems to be incorrect. -; This presumes that your drawing will completely fill the bounding rectangle of the sheet -; and will effectively randomise anything that isn't draw, within it. -; FIXME +;;; XXX This seems to be incorrect. +;;; This presumes that your drawing will completely fill the bounding rectangle +;;; of the sheet and will effectively randomize anything that isn't drawn +;;; within it. +;;; FIXME +#+nil (defmacro with-double-buffering ((sheet) &body body) (let ((width (gensym)) (height (gensym)) @@ -687,6 +689,115 @@ ; in which case, we shouldn't blit it back (copy-from-pixmap ,pixmap 0 0 ,width ,height ,sheet 0 0)) (deallocate-pixmap ,pixmap))))) + +;;; Another attempt + +(defun invoke-with-double-buffering (sheet continuation x1 y1 x2 y2) + (let* ((medium (sheet-medium sheet)) + (sheet-transform (sheet-native-transformation sheet)) + (medium-transform (medium-transformation (sheet-medium sheet))) + (world-transform (compose-transformations sheet-transform + medium-transform))) + (multiple-value-bind (sheet-x1 sheet-y1) + (transform-position world-transform x1 y1) + (multiple-value-bind (sheet-x2 sheet-y2) + (transform-position world-transform x2 y2) + ;; Be conservative with the size of the pixmap, including all of + ;; the pixels at the edges. + (let* ((pixmap-x1 (floor sheet-x1)) + (pixmap-y1 (floor sheet-y1)) + (pixmap-x2 (ceiling sheet-x2)) + (pixmap-y2 (ceiling sheet-y2)) + (pixmap-width (- pixmap-x2 pixmap-x1)) + (pixmap-height (- pixmap-y2 pixmap-y1)) + (current-sheet-region (sheet-region sheet)) + (sheet-native (compose-transformation-with-translation + sheet-transform + (- pixmap-x1) + (- pixmap-y1))) + (pixmap (allocate-pixmap sheet pixmap-width pixmap-height)) + ) + (unless pixmap + (error "Couldn't allocate pixmap")) + (multiple-value-bind (user-pixmap-x1 user-pixmap-y1) + (untransform-position world-transform pixmap-x1 pixmap-y1) + (multiple-value-bind (user-pixmap-x2 user-pixmap-y2) + (untransform-position world-transform pixmap-x2 pixmap-y2) + (flet ((set-native (transform region sheet) + (%%set-sheet-native-transformation transform sheet) + (setf (slot-value sheet 'region) region) + (invalidate-cached-regions sheet) + (invalidate-cached-transformations sheet))) + ;; Assume that the scaling for the sheet-native + ;; transformation for the pixmap will be the same as that of + ;; the mirror . + (unwind-protect + (letf (((sheet-parent sheet) nil) + ((sheet-direct-mirror sheet) + (pixmap-mirror pixmap))) + (unwind-protect + (let ((pixmap-region + (make-bounding-rectangle user-pixmap-x1 + user-pixmap-y1 + user-pixmap-x2 + user-pixmap-y2))) + (set-native sheet-native pixmap-region sheet) + ;(break) + (with-drawing-options + (medium :ink (medium-background medium)) + + (medium-draw-rectangle* medium + user-pixmap-x1 + user-pixmap-y1 + user-pixmap-x2 + user-pixmap-y2 + t)) + (funcall continuation sheet + user-pixmap-x1 user-pixmap-y1 + user-pixmap-x2 user-pixmap-y2)) + (set-native sheet-transform + current-sheet-region + sheet))) + (copy-from-pixmap pixmap 0 0 + pixmap-width pixmap-height sheet + user-pixmap-x1 user-pixmap-y1) + (deallocate-pixmap pixmap)))))))))) + +(defmacro with-double-buffering (((sheet &rest bounds-args) + (&rest pixmap-args)) + &body body) + (with-gensyms (continuation) + (let ((cont-form + (case (length pixmap-args) + (1 + (with-gensyms (pixmap-x1 pixmap-y1 pixmap-x2 pixmap-y2) + `(,continuation (,sheet + ,pixmap-x1 ,pixmap-y1 ,pixmap-x2 ,pixmap-y2) + (let ((,(car pixmap-args) + (make-bounding-rectangle ,pixmap-x1 ,pixmap-y1 + ,pixmap-x2 ,pixmap-y2))) + ,@body)))) + (4 + `(,continuation (,sheet ,@pixmap-args) + ,@body)) + (otherwise (error "Invalid pixmap-args ~S" pixmap-args))))) + (case (length bounds-args) + (1 + (with-gensyms (x1 y1 x2 y2) + `(flet (,cont-form) + (declare (dynamic-extent #',continuation)) + (with-bounding-rectangle* (,x1 ,y1 ,x2 ,y2) + ,(car bounds-args) + (invoke-with-double-buffering ,sheet + #',continuation + ,x1 ,y1 ,x2 ,y2))))) + (4 + `(flet (,cont-form) + (declare (dynamic-extent #',continuation)) + (invoke-with-double-buffering ,sheet #',continuation + ,@bounds-args))) + (otherwise (error "invalid bounds-args ~S" bounds-args)))))) + ;;; Generic graphic operation methods Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.40 mcclim/incremental-redisplay.lisp:1.41 --- mcclim/incremental-redisplay.lisp:1.40 Sun Oct 24 17:47:02 2004 +++ mcclim/incremental-redisplay.lisp Tue Jan 11 14:35:18 2005 @@ -105,7 +105,9 @@ (id-counter :accessor id-counter :documentation "The counter used to assign unique ids to updating output records without one.") - (tester-function :accessor tester-function :initform 'none) + (tester-function :accessor tester-function :initform 'none + :documentation "The function used to lookup + updating output records in this map if unique; otherwise, :mismatch.") (element-count :accessor element-count :initform 0))) ;;; Complete guess... @@ -113,6 +115,8 @@ "The limit at which the id map in an updating output record switches to a hash table.") +;;; ((eq map-test-func :mismatch) +;;; nil) (defun function-matches-p (map func) (let ((map-test-func (tester-function map))) (cond ((eq map-test-func func) @@ -125,19 +129,25 @@ (eq map-test-func (symbol-value func))) (t nil)))) +(defun ensure-test (map test) + (unless (function-matches-p map test) + (explode-map-hash map) + (setf (tester-function map) :mismatch))) + (defun get-from-map (map value test) (when (eq (tester-function map) 'none) (return-from get-from-map nil)) - (if (function-matches-p map test) - (let ((map (id-map map))) - (if (hash-table-p map) - (gethash value map) - (cdr (assoc value map :test test)))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (ensure-test map test) + (let ((map (id-map map))) + (if (hash-table-p map) + (gethash value map) + (cdr (assoc value map :test test))))) + (defun maybe-convert-to-hash (map) (let ((test (tester-function map))) - (when (and (> (element-count map) *updating-map-threshold*) + (when (and (not (eq test :mismatch)) + (> (element-count map) *updating-map-threshold*) (or (case test ((eq eql equal equalp) t)) (eq test #'eq) @@ -150,42 +160,48 @@ do (setf (gethash key new-map) value)) (setf (id-map map) new-map))))) +(defun explode-map-hash (map) + (let ((hash-map (id-map map))) + (when (hash-table-p hash-map) + (loop + for key being each hash-key of hash-map using (hash-value record) + collect (cons key record) into alist + finally (setf (id-map map) alist))))) + (defun add-to-map (map record value test replace) - (when (eq (tester-function map) 'none) - (setf (tester-function map) test)) - (if (function-matches-p map test) - (let ((val-map (id-map map))) - (if (hash-table-p val-map) - (multiple-value-bind (existing-value in-table) - (if replace - (gethash value val-map) - (values nil nil)) - (declare (ignore existing-value)) - (setf (gethash value val-map) record) - (unless in-table - (incf (element-count map)))) - (let ((val-cons (if replace - (assoc value val-map :test test) - nil))) - (if val-cons - (setf (cdr val-cons) record) - (progn - (setf (id-map map) (acons value record val-map)) - (incf (element-count map)) - (maybe-convert-to-hash map)))))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (if (eq (tester-function map) 'none) + (setf (tester-function map) test) + (ensure-test map test)) + (let ((val-map (id-map map))) + (if (hash-table-p val-map) + (multiple-value-bind (existing-value in-table) + (if replace + (gethash value val-map) + (values nil nil)) + (declare (ignore existing-value)) + (setf (gethash value val-map) record) + (unless in-table + (incf (element-count map)))) + (let ((val-cons (if replace + (assoc value val-map :test test) + nil))) + (if val-cons + (setf (cdr val-cons) record) + (progn + (setf (id-map map) (acons value record val-map)) + (incf (element-count map)) + (maybe-convert-to-hash map))))))) (defun delete-from-map (map value test) - (if (function-matches-p map test) - (let ((val-map (id-map map)) - (deleted nil)) - (if (hash-table-p val-map) - (setf deleted (remhash value val-map)) - (setf (values (id-map map) deleted) - (delete-1 value val-map :test test :key #'car))) - (when deleted - (decf (element-count map)))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (ensure-test map test) + (let ((val-map (id-map map)) + (deleted nil)) + (if (hash-table-p val-map) + (setf deleted (remhash value val-map)) + (setf (values (id-map map) deleted) + (delete-1 value val-map :test test :key #'car))) + (when deleted + (decf (element-count map))))) (defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names &key) @@ -887,10 +903,6 @@ (setf (parent-cache record) parent-cache))) record))) -;;; &key (unique-id (gensym)) was used earlier, -;;; changed to (unique-id `',(gensym)) as per gilham's request -;;; please CHECKME and delete this comment :] -;;; ;;; The Franz user guide says that updating-output does ;;; &allow-other-keys, and some code I've encountered does mention ;;; other magical arguments, so we'll do the same. -- moore Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.46 mcclim/package.lisp:1.47 --- mcclim/package.lisp:1.46 Mon Dec 20 16:49:19 2004 +++ mcclim/package.lisp Tue Jan 11 14:35:18 2005 @@ -409,6 +409,7 @@ #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant + #:+text-field-view+ ;constant (Franz User's Guide) #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant @@ -1104,7 +1105,6 @@ #:pointer-event-x ;generic function #:pointer-event-y ;generic function #:pointer-exit-event ;class - #:pointer-modifier-state ;generic function (in franz user guide) #:pointer-motion-event ;class #:pointer-position ;generic function #:pointer-sheet ;generic function @@ -1119,6 +1119,7 @@ #:port ;protocol class #:port ;generic function #:port-keyboard-input-focus ;generic function + #:port-modifier-state ;generic function (in franz user guide) #:port-name ;generic function #:port-pointer ;generic function (in franz user guide) #:port-properties ;generic function @@ -1456,6 +1457,7 @@ #:text-editor-pane ;class #:text-field ;class #:text-field-pane ;class + #:text-field-view ;class (Franz User's Guide) #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function Index: mcclim/pointer-tracking.lisp diff -u mcclim/pointer-tracking.lisp:1.15 mcclim/pointer-tracking.lisp:1.16 --- mcclim/pointer-tracking.lisp:1.15 Fri Nov 12 07:39:44 2004 +++ mcclim/pointer-tracking.lisp Tue Jan 11 14:35:18 2005 @@ -173,64 +173,126 @@ ;;; multiple-window is completely unsupported. ;;; window-repaint events while dragging. +(defun bound-rectangles (r1-x1 r1-y1 r1-x2 r1-y2 r2-x1 r2-y1 r2-x2 r2-y2) + (values (min r1-x1 r2-x1) (min r1-y1 r2-y1) + (max r1-x2 r2-x2) (max r1-y2 r2-y2))) + + (defgeneric drag-output-record (stream output &key repaint erase feedback finish-on-release multiple-window)) +;;; Fancy double-buffered feedback function +(defun make-buffered-feedback-function (record finish-on-release erase-final) + (multiple-value-bind (record-x record-y) + (output-record-position record) + (lambda (record stream initial-x initial-y x y event) + (flet ((simple-erase () + (when erase-final + (when (output-record-parent record) + (delete-output-record record (output-record-parent record))) + (with-double-buffering + ((stream record) (buffer-rectangle)) + (stream-replay stream buffer-rectangle))))) + (let ((dx (- record-x initial-x)) + (dy (- record-y initial-y))) + (typecase event + (null + (setf (output-record-position record) (values (+ dx x) (+ dy y))) + (stream-add-output-record stream record) + (stream-replay stream record)) + (pointer-motion-event + ;; Don't do an explicit erase. Instead, update the position of the + ;; output record and redraw the union of the old and new + ;; positions. + (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) + record + (when (output-record-parent record) + (delete-output-record record (output-record-parent record))) + (setf (output-record-position record) + (values (+ dx x) (+ dy y))) + (stream-add-output-record stream record) + (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) + record + (multiple-value-bind (area-x1 area-y1 area-x2 area-y2) + (bound-rectangles old-x1 old-y1 old-x2 old-y2 + new-x1 new-y1 new-x2 new-y2) + (with-double-buffering + ((stream area-x1 area-y1 area-x2 area-y2) + (buffer-rectangle)) + (stream-replay stream buffer-rectangle)))))) + (pointer-button-press-event + (unless finish-on-release + (simple-erase))) + (pointer-button-release-event + (when finish-on-release + (simple-erase))) + (t nil))))))) + +;;; If the user supplies a feedback function, create a function to +;;; call it with the simple :draw / :erase arguments. + +(defun make-simple-feedback-function + (record feedback finish-on-release erase-final) + (declare (ignore record)) + (lambda (record stream initial-x initial-y x y event) + (typecase event + (null + (funcall feedback record stream initial-x initial-y x y :draw)) + (pointer-motion-event + (funcall feedback record stream initial-x initial-y x y :erase) + (funcall feedback record stream initial-x initial-y x y :draw)) + (pointer-button-press-event + (unless finish-on-release + (when erase-final + (funcall feedback record stream initial-x initial-y x y :erase)))) + (pointer-button-release-event + (when (and finish-on-release erase-final) + (funcall feedback record stream initial-x initial-y x y :erase))) + (t nil)))) + + (defmethod drag-output-record ((stream output-recording-stream) (record output-record) &key (repaint t) (erase #'erase-output-record) feedback finish-on-release multiple-window - feedback-event) - (declare (ignore repaint multiple-window)) - (multiple-value-bind (dx dy) - (output-record-position record) - (flet ((feedback-fn (record stream initial-x initial-y x y action) - (declare (ignore initial-x initial-y)) - (if (eq action :erase) - (funcall erase record stream) - (progn - (setf (output-record-position record) - (values (+ dx x) (+ dy y))) - (stream-add-output-record stream record) - (stream-replay stream record)))) - (feedback-event-fn (record stream initial-x initial-y x y - action event) - (declare (ignore event)) - (when (or (eq action :draw) (eq action :erase)) - (funcall feedback record stream initial-x initial-y x y - action)))) - (declare (dynamic-extent #'feedback-fn #'feedback-event-fn)) - (unless feedback - (setq feedback #'feedback-fn)) - (unless feedback-event - (setq feedback-event #'feedback-event-fn)) - (setf (stream-current-output-record stream) - (stream-output-history stream)) - (let* ((pointer (port-pointer (port stream))) - (pointer-state (pointer-button-state pointer))) - (multiple-value-bind (x0 y0) - (stream-pointer-position stream) - (funcall feedback-event record stream x0 y0 x0 y0 :draw nil) - (tracking-pointer (stream) - (:pointer-motion (&key event x y) - ;; XXX What about the sheet? - (funcall feedback-event record stream x0 y0 x y :erase event) - (funcall feedback-event record stream x0 y0 x y :draw event)) - (:pointer-button-press (&key event x y) - (funcall feedback-event record stream x0 y0 x y - :button-press event) - (unless finish-on-release - (return-from drag-output-record (values x y)))) - (:pointer-button-release (&key event x y) - ;; If the button released was one of those held down on entry to - ;; drag-output-record, we're done. - (when (and finish-on-release - (not (zerop (logand pointer-state - (pointer-event-button event))))) - (funcall feedback-event record stream x0 y0 x y - :button-release event) - (return-from drag-output-record (values x y)))))))))) + feedback-event erase-final) + (declare (ignore erase repaint multiple-window)) + (let ((feedback-event-fn + (cond (feedback-event + feedback-event) + (feedback + (make-simple-feedback-function record + feedback + finish-on-release + erase-final)) + (t (make-buffered-feedback-function record + finish-on-release + erase-final))))) + (setf (stream-current-output-record stream) + (stream-output-history stream)) + (let* ((pointer (port-pointer (port stream))) + (pointer-state (pointer-button-state pointer))) + (multiple-value-bind (x0 y0) + (stream-pointer-position stream) + (funcall feedback-event-fn record stream x0 y0 x0 y0 nil) + (tracking-pointer (stream) + (:pointer-motion (&key event x y) + ;; XXX What about the sheet? + (funcall feedback-event-fn record stream x0 y0 x y event) + (funcall feedback-event-fn record stream x0 y0 x y event)) + (:pointer-button-press (&key event x y) + (unless finish-on-release + (funcall feedback-event-fn record stream x0 y0 x y event) + (return-from drag-output-record (values x y)))) + (:pointer-button-release (&key event x y) + ;; If the button released was one of those held down on entry to + ;; drag-output-record, we're done. + (when (and finish-on-release + (not (zerop (logand pointer-state + (pointer-event-button event))))) + (funcall feedback-event-fn record stream x0 y0 x y event) + (return-from drag-output-record (values x y))))))))) (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args &key repaint finish-on-release multiple-window) @@ -240,7 +302,6 @@ (with-gensyms (record) `(let ((,record (with-output-to-output-record (,stream) ,@body))) - (multiple-value-prog1 - (drag-output-record ,stream ,record ,@args) - (erase-output-record ,record ,stream))))) + (drag-output-record ,stream ,record :erase-final t ,@args)))) + Index: mcclim/sheets.lisp diff -u mcclim/sheets.lisp:1.47 mcclim/sheets.lisp:1.48 --- mcclim/sheets.lisp:1.47 Sun Dec 5 20:37:52 2004 +++ mcclim/sheets.lisp Tue Jan 11 14:35:18 2005 @@ -413,11 +413,15 @@ (defmethod sheet-native-region ((sheet basic-sheet)) (with-slots (native-region) sheet (unless native-region - (setf native-region (region-intersection - (transform-region - (sheet-native-transformation sheet) - (sheet-region sheet)) - (sheet-native-region (sheet-parent sheet))))) + (let ((this-native-region (transform-region + (sheet-native-transformation sheet) + (sheet-region sheet))) + (parent (sheet-parent sheet))) + (setf native-region (if parent + (region-intersection this-native-region + (sheet-native-region + parent)) + this-native-region)))) native-region)) (defmethod sheet-device-transformation ((sheet basic-sheet)) @@ -706,15 +710,17 @@ (defmethod sheet-native-region ((sheet mirrored-sheet-mixin)) (with-slots (native-region) sheet (unless native-region - (setf native-region - (region-intersection - (transform-region - (sheet-native-transformation sheet) - (sheet-region sheet)) - (transform-region - (invert-transformation - (%sheet-mirror-transformation sheet)) - (sheet-native-region (sheet-parent sheet)))))) + (let ((this-region (transform-region (sheet-native-transformation sheet) + (sheet-region sheet))) + (parent (sheet-parent sheet))) + (setf native-region + (if parent + (region-intersection this-region + (transform-region + (invert-transformation + (%sheet-mirror-transformation sheet)) + (sheet-native-region parent))) + this-region)))) native-region)) (defmethod (setf sheet-enabled-p) :after (new-value (sheet mirrored-sheet-mixin))

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/menu-choose.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv15555/Experimental Modified Files: menu-choose.lisp Log Message: Eat the pointer-release events from a menu choose action. Otherwise, they will still be around when if a command, invoked by the menu, starts looking at the event queue. Completely bypass the standard presentation translator mechanism when determining whether to call the presentation clauses in TRACKING-POINTER. Presentation translators and actions can't do anything here. Date: Tue Jan 11 14:14:21 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.13 mcclim/Experimental/menu-choose.lisp:1.14 --- mcclim/Experimental/menu-choose.lisp:1.13 Sun Oct 31 02:46:31 2004 +++ mcclim/Experimental/menu-choose.lisp Tue Jan 11 14:14:21 2005 @@ -266,15 +266,27 @@ :width x2 :height y2 :resize-frame t))) - (let ((*pointer-documentation-output* pointer-documentation)) - (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) - (:pointer-button-press (&key event x y) ; Pointer clicked outside menu? Close the menu. - (unless (and (sheet-ancestor-p (event-sheet event) menu) - (region-contains-position-p (sheet-region menu) x y)) - (return-from menu-choose-from-drawer (values nil)))) - (:presentation-button-press (&key event presentation x y) + ;; Eat pointer release event so it isn't fed spuriously to another + ;; command entering its own tracking-pointer loop. + (let ((*pointer-documentation-output* pointer-documentation) + (exit-menu nil)) + (tracking-pointer (menu :context-type presentation-type + :multiple-window t :highlight t) + (:presentation (&key presentation) + (format *trace-output* "type:~S presentation:~S~%" + presentation-type + presentation) + (setq exit-menu t)) + (:pointer-button-release (&key event x y) ; Pointer clicked outside menu? + ; Close the menu. + (when exit-menu + (unless (and (sheet-ancestor-p (event-sheet event) menu) + (region-contains-position-p (sheet-region menu) x y)) + (return-from menu-choose-from-drawer (values nil))))) + (:presentation-button-release (&key event presentation x y) (if (and (sheet-ancestor-p (event-sheet event) menu) (region-contains-position-p (sheet-region menu) x y)) (return-from menu-choose-from-drawer (values (presentation-object presentation) event)) (return-from menu-choose-from-drawer (values nil))))))) +

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15555 Modified Files: frames.lisp Log Message: Eat the pointer-release events from a menu choose action. Otherwise, they will still be around when if a command, invoked by the menu, starts looking at the event queue. Completely bypass the standard presentation translator mechanism when determining whether to call the presentation clauses in TRACKING-POINTER. Presentation translators and actions can't do anything here. Date: Tue Jan 11 14:14:19 2005 Author: tmoore Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.103 mcclim/frames.lisp:1.104 --- mcclim/frames.lisp:1.103 Fri Nov 12 07:38:50 2004 +++ mcclim/frames.lisp Tue Jan 11 14:14:18 2005 @@ -1337,23 +1337,47 @@ (cdr hilited) :unhighlight))))) +;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to +;;; see any results from presentation translators. + +(defun highlight-for-tracking-pointer (frame stream x y input-context) + (let ((context-ptype (input-context-type (car input-context))) + (presentation nil) + (current-hilited (frame-hilited-presentation frame))) + (if (output-recording-stream-p stream) + (progn + (block found-presentation + (flet ((do-presentation (p) + (when (presentation-subtypep (presentation-type p) + context-ptype) + (setq presentation p) + (return-from found-presentation nil)))) + (declare (dynamic-extent #'do-presentation)) + (map-over-presentations-containing-position + #'do-presentation (stream-output-history stream) x y))) + (when (and current-hilited + (not (eq (car current-hilited) presentation))) + (highlight-presentation-1 (car current-hilited) + (cdr current-hilited) + :unhighlight)) + (if presentation + (progn + (setf (frame-hilited-presentation frame) + (cons presentation stream)) + (highlight-presentation-1 presentation stream :highlight))) + presentation)))) + (defmethod tracking-pointer-loop-step :before ((state frame-tracking-pointer-state) (event pointer-event) x y) (declare (ignore x y)) (when (highlight state) (let ((stream (event-sheet event))) (setf (applicable-presentation state) - (frame-highlight-at-position *application-frame* stream - (device-event-x event) - (device-event-y event) - (event-modifier-state event) - (input-context state) - :highlight (highlight state))) - ;;; Hmmm, probably don't want to do this - #+nil (frame-update-pointer-documentation frame - (input-context state) - stream - event)))) + (highlight-for-tracking-pointer *application-frame* stream + (device-event-x event) + (device-event-y event) + (input-context state)))))) + (macrolet ((frob (event handler) `(defmethod tracking-pointer-loop-step

1 0

[mcclim-cvs] CVS update: mcclim/presentations.lisp mcclim/presentation-defs.lisp mcclim/dialog.lisp mcclim/views.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14709 Modified Files: presentations.lisp presentation-defs.lisp dialog.lisp views.lisp Log Message: Implement :SINGLE-BOX properly.:SINGLE-BOX NIL is the default, but McCLIM has ignored it. This changes (for the better) the behavior of applications. Implement PRESENTATION-REFINED-POSITION-TEST. If the view argument to ACCEPT is a list, apply MAKE-INSTANCE to the list to obtain the view. Fix a bug in dialogs that prevented moving on to the next text field after hitting return. Define a new view type, TEXT-FIELD-VIEW, that is used in dialogs. This view has a WIDTH parameter. Date: Tue Jan 11 14:02:29 2005 Author: tmoore Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.68 mcclim/presentations.lisp:1.69 --- mcclim/presentations.lisp:1.68 Sun Nov 7 20:33:31 2004 +++ mcclim/presentations.lisp Tue Jan 11 14:02:19 2005 @@ -1107,7 +1107,8 @@ ,@lambda-list) (declare (ignorable ,(type-key-arg gf)) ,@(cdr decls)) - ,@body)))) + (block ,name + ,@body))))) ;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function. (defun %funcall-presentation-generic-function (name gf type-arg-position @@ -1283,6 +1284,10 @@ &allow-other-keys) arglist &body body) + ;; null tester should be the same as no tester + (unless tester + (setq tester 'default-translator-tester) + (setq tester-definitive t)) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-to-type (expand-presentation-type-abbreviation to-type))) (with-keywords-removed (translator-options @@ -1586,15 +1591,7 @@ t) -(defun presentation-contains-position (record x y) - (let ((single-box (presentation-single-box record))) - (multiple-value-bind (min-x min-y max-x max-y) - (output-record-hit-detection-rectangle* record) - (if (and (<= min-x x max-x) (<= min-y y max-y)) - (if (or (null single-box) (eq single-box :higlighting)) - (output-record-refined-position-test record x y) - t) - nil)))) +;;; presentation-contains-position moved to presentation-defs.lisp (defun map-over-presentations-containing-position (func record x y) "maps recursively over all presentations in record, including record." @@ -1799,7 +1796,8 @@ a presentation" (throw-highlighted-presentation (make-instance 'standard-presentation - :object object :type type) + :object object :type type + :single-box t) input-context (make-instance 'pointer-button-press-event :sheet sheet Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.38 mcclim/presentation-defs.lisp:1.39 --- mcclim/presentation-defs.lisp:1.38 Sun Jan 2 06:28:38 2005 +++ mcclim/presentation-defs.lisp Tue Jan 11 14:02:19 2005 @@ -647,7 +647,7 @@ (defun accept (type &rest rest-args &key (stream *standard-input*) - view + (view nil viewp) (default nil defaultp) (default-type nil default-type-p) provide-default insert-default replace-input @@ -680,6 +680,12 @@ (list* :default-type real-default-type rest-args))) (when historyp (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) ;; Presentation type history interaction. According to the spec, ;; if provide-default is true, we take the default from the ;; presentation history. In addition, we'll implement the Genera @@ -929,6 +935,40 @@ (with-input-from-string (stream string :start start :end end) (with-keywords-removed (args (:start :end)) (apply #'stream-accept stream type :view +textual-view+ args)))) + +(define-presentation-generic-function %presentation-refined-position-test + presentation-refined-position-test + (type-key parameters options type record x y)) + +(define-default-presentation-method presentation-refined-position-test + (type record x y) + (declare (ignore type)) + ;;; output-record-hit-detection-rectangle* has already been called + (let ((single-box (presentation-single-box record))) + (if (or (eq single-box t) (eq single-box :position)) + t + (labels ((tester (record) + (typecase record + (displayed-output-record + (return-from presentation-refined-position-test t)) + (compound-output-record + (map-over-output-records-containing-position + #'tester record x y)) + (t nil)))) + (tester record) + nil)))) + +(defun presentation-contains-position (record x y) + (let ((single-box (presentation-single-box record))) + (multiple-value-bind (min-x min-y max-x max-y) + (output-record-hit-detection-rectangle* record) + (if (and (<= min-x x max-x) (<= min-y y max-y)) + (if (or (null single-box) (eq single-box :higlighting)) + (funcall-presentation-generic-function + presentation-refined-position-test + (presentation-type record) record x y) + t) + nil)))) (define-presentation-generic-function %highlight-presentation highlight-presentation Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.15 mcclim/dialog.lisp:1.16 --- mcclim/dialog.lisp:1.15 Sun Jan 2 06:24:49 2005 +++ mcclim/dialog.lisp Tue Jan 11 14:02:19 2005 @@ -318,11 +318,12 @@ (when query (setf selected-query query) (select-query *accepting-values-stream* query (record query)) - (if (cdr query-list) - (throw-object-ptype (query-identifier (cadr query-list)) - 'selectable-query) - (throw-object-ptype '(com-deselect-query) - '(command :command-table accepting-values)))))))) + (let ((command-ptype '(command :command-table accepting-values))) + (if (cdr query-list) + (throw-object-ptype `(com-select-query ,(query-identifier + (cadr query-list))) + command-ptype) + (throw-object-ptype '(com-deselect-query) command-ptype)))))))) (define-command (com-deselect-query :command-table accepting-values :name nil @@ -344,6 +345,24 @@ is called. Used to determine if any editing has been done by user"))) (defparameter *no-default-cache-value* (cons nil nil)) + +;;; Hack until more views / dialog gadgets are defined. + +(define-default-presentation-method accept-present-default + (type stream (view text-field-view) default default-supplied-p + present-p query-identifier) + (if (width view) + (multiple-value-bind (cx cy) + (stream-cursor-position stream) + (declare (ignore cy)) + (letf (((stream-text-margin stream) (+ cx (width view)))) + (funcall-presentation-generic-function accept-present-default + type + stream + +textual-dialog-view+ + default default-supplied-p + present-p + query-identifier))))) (define-default-presentation-method accept-present-default (type stream (view textual-dialog-view) default default-supplied-p Index: mcclim/views.lisp diff -u mcclim/views.lisp:1.5 mcclim/views.lisp:1.6 --- mcclim/views.lisp:1.5 Mon Nov 3 09:12:35 2003 +++ mcclim/views.lisp Tue Jan 11 14:02:19 2005 @@ -44,6 +44,11 @@ (defclass pointer-documentation-view (textual-view) ()) +;;; Views described in the Franz User manual... + +(defclass text-field-view (gadget-dialog-view) + ((width :accessor width :initarg :width :initform nil))) + (defparameter +textual-view+ (make-instance 'textual-view)) (defparameter +textual-menu-view+ (make-instance 'textual-menu-view)) @@ -58,6 +63,8 @@ (defparameter +pointer-documentation-view+ (make-instance 'pointer-documentation-view)) + +(defparameter +text-field-view+ (make-instance 'text-field-view)) (defmethod stream-default-view (stream) (declare (ignore stream))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Scigraph/scigraph/mouse.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph In directory common-lisp.net:/tmp/cvs-serv14169 Modified Files: mouse.lisp Log Message: Add McCLIM (in fact, portable) code to button-case Date: Tue Jan 11 13:45:38 2005 Author: tmoore Index: mcclim/Apps/Scigraph/scigraph/mouse.lisp diff -u mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.5 mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.6 --- mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.5 Fri Aug 6 15:19:40 2004 +++ mcclim/Apps/Scigraph/scigraph/mouse.lisp Tue Jan 11 13:45:35 2005 @@ -60,7 +60,7 @@ ,@(if right `(((clim::button-press-event-matches-gesture-name ,button :menu) ,right))))) - (:clim-2 + ((and :clim-2 (not :mcclim)) `(cond ,@(if left `(((clim-internals::button-press-event-matches-gesture-name-p ,button :select) @@ -70,7 +70,18 @@ ,middle))) ,@(if right `(((clim-internals::button-press-event-matches-gesture-name-p ,button :menu) - ,right))))))) + ,right))))) + (:mcclim + `(cond + ,@(when left + `(((event-matches-gesture-name-p ,button :select) + ,left))) + ,@(when middle + `(((event-matches-gesture-name-p ,button :describe) + ,middle))) + ,@(when right + `(((event-matches-gesture-name-p ,button :menu) + ,right))))))) (defmethod post-mouse-documentation (stream string) #FEATURE-CASE

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/listener.lisp
by ahefner＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv24962 Modified Files: listener.lisp Log Message: Adjust default width and height of the listener to fit on most screens. Date: Tue Jan 11 06:26:37 2005 Author: ahefner Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.20 mcclim/Apps/Listener/listener.lisp:1.21 --- mcclim/Apps/Listener/listener.lisp:1.20 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/listener.lisp Tue Jan 11 06:26:26 2005 @@ -319,8 +319,8 @@ (defun run-listener (&key (system-command-reader nil) (new-process nil) - (width 800) - (height 800) + (width 760) + (height 550) (process-name "Listener") (eval nil)) (flet ((run ()

1 0

[mcclim-cvs] CVS update: mcclim/text-selection.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14779 Modified Files: text-selection.lisp Log Message: Fix bug in text selection code causing an error if the user attempts to drag a selection endpoint before any text has been selected. (Previous commit to CLX backend had nothing to do with this, sorry) Date: Sun Jan 2 06:31:32 2005 Author: ahefner Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.1 mcclim/text-selection.lisp:1.2 --- mcclim/text-selection.lisp:1.1 Tue Dec 7 05:49:51 2004 +++ mcclim/text-selection.lisp Sun Jan 2 06:31:32 2005 @@ -218,15 +218,16 @@ ;; paste (request-selection (port pane) #|:UTF8_STRING|# (sheet-direct-mirror pane) (event-timestamp event))) ((eql +pointer-right-button+ (pointer-event-button event)) - ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around. - (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2) - (expt (- (pointer-event-y event) point-1-y) 2)) - (+ (expt (- (pointer-event-x event) point-2-x) 2) - (expt (- (pointer-event-y event) point-2-y) 2))) - (rotatef point-1-x point-2-x) - (rotatef point-1-y point-2-y)) - (eos/shift-drag pane event) - (setf dragging-p t)) + (when (and point-1-x point-1-y point-2-x point-2-y) + ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around. + (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2) + (expt (- (pointer-event-y event) point-1-y) 2)) + (+ (expt (- (pointer-event-x event) point-2-x) 2) + (expt (- (pointer-event-y event) point-2-y) 2))) + (rotatef point-1-x point-2-x) + (rotatef point-1-y point-2-y)) + (eos/shift-drag pane event) + (setf dragging-p t))) (t (describe event))))) (defmethod eos/shift-release ((pane extended-output-stream) event)

1 0

[mcclim-cvs] CVS update: mcclim/Examples/gadget-test.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv14647/Examples Modified Files: gadget-test.lisp Log Message: Cleanups to gadget-test. Date: Sun Jan 2 06:29:19 2005 Author: ahefner Index: mcclim/Examples/gadget-test.lisp diff -u mcclim/Examples/gadget-test.lisp:1.11 mcclim/Examples/gadget-test.lisp:1.12 --- mcclim/Examples/gadget-test.lisp:1.11 Wed Jul 7 12:08:55 2004 +++ mcclim/Examples/gadget-test.lisp Sun Jan 2 06:29:19 2005 @@ -19,40 +19,36 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Copied from colorslider +(in-package :clim-demo) -(in-package :clim-internals) +;; Gadget Test/Demo -;; example gadget definition -(defclass gadget-test-pane (standard-gadget) ()) +;; To run the gadget test: (clim-demo:gadget-test) -(in-package :clim-demo) +;; McCLIM contains an alternate look and feel entitled "pixie" which is +;; not the default. It can by used by creating your application using an +;; alternate frame manager, clim-internals::pixie/clx-look. + +;; To run the gadget test using the pixie frame manager: +;; (gadget-test 'clim-internals::pixie/clx-look) +;; This may require you to load the clim-looks system. + +(defun gadget-test (&optional frame-manager-name) + (run-frame-top-level + (if frame-manager-name + (make-application-frame 'gadget-test + :frame-manager (make-instance frame-manager-name + :port (find-port))) + (make-application-frame 'gadget-test)))) -(defun gadget-test () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) - (setq frame (make-application-frame 'gadget-test - :frame-manager (make-instance 'clim-internals::pixie/clx-look - :port (find-port)))) -; (setq frame (make-application-frame 'gadget-test)) - (setq fm (frame-manager frame)) - (setq port (climi::frame-manager-port fm)) - (setq pane (frame-panes frame)) - (setq medium (sheet-medium pane)) - (setq graft (graft frame)) - ;(setq vbox (climi::frame-pane frame)) - (run-frame-top-level frame)) +(export 'gadget-test) (defun run-pixie-test (name) - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (when name (run-frame-top-level - (make-application-frame name - :frame-manager (make-instance 'clim-internals:pixie/clx-look - :port (find-port)))))) + (make-application-frame name + :frame-manager (make-instance 'clim-internals::pixie/clx-look + :port (find-port)))))) (defmethod gadget-test-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) @@ -232,7 +228,10 @@ (:top-level (gadget-test-frame-top-level . nil))) (defmethod run-frame-top-level :around ((frame gadget-test) &key &allow-other-keys) - (clim-internals::schedule-timer-event (find-pane-named frame 'radar) 'radiate 0.1) + ;; FIXME: Timer events appear to have rotted. + ;; Also, the following won't work because the frame has not really been realized yet, + ;; so you can't get at its panes. Yet it has worked, and recently. Odd. + ;; (clim-internals::schedule-timer-event (find-pane-named frame 'radar) 'radiate 0.1) (call-next-method)) (defclass radar-pane (basic-gadget) (

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv14626/Backends/CLX Modified Files: port.lisp Log Message: Fix bug in text selection code causing an error if the user attempts to drag a selection endpoint before any text has been selected. Fix to decode-x-button-code for users with more than five mouse buttons. Date: Sun Jan 2 06:29:03 2005 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.101 mcclim/Backends/CLX/port.lisp:1.102 --- mcclim/Backends/CLX/port.lisp:1.101 Tue Dec 28 11:06:21 2004 +++ mcclim/Backends/CLX/port.lisp Sun Jan 2 06:29:03 2005 @@ -238,8 +238,9 @@ (setf (xlib:display-error-handler (clx-port-display port)) #'clx-error-handler) - #+nil + #+nil ;; Uncomment this when debugging CLX backend if asynchronous errors become troublesome.. (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-force-output)) + (setf (clx-port-screen port) (nth (getf options :screen-id 0) (xlib:display-roots (clx-port-display port)))) @@ -531,13 +532,16 @@ (progn ,@body))))))) -(defun decode-x-button-code (code) - (aref #.(vector +pointer-left-button+ - +pointer-middle-button+ - +pointer-right-button+ - +pointer-wheel-up+ - +pointer-wheel-down+) - (1- code))) +(defun decode-x-button-code (code) + (let ((button-mapping #.(vector +pointer-left-button+ + +pointer-middle-button+ + +pointer-right-button+ + +pointer-wheel-up+ + +pointer-wheel-down+))) + (if (and (> code 0) + (<= code (1+ (length button-mapping)))) + (aref button-mapping (1- code)) + nil))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5: @@ -1063,7 +1067,8 @@ (or (gethash color table) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) - (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) + (xlib:alloc-color (xlib:screen-default-colormap + (clx-port-screen port)) (xlib:make-color :red r :green g :blue b))))))) (defmethod port-mirror-width ((port clx-port) sheet) @@ -1352,6 +1357,8 @@ (xlib:convert-selection :primary :UTF8_STRING requestor :bounce time)) (defmethod get-selection-from-event ((event clx-selection-notify-event)) + (when (null (selection-event-property event)) + (format *trace-output* "~&;; Notify property is null! Why did this happen?~%")) (map 'string #'code-char (xlib:get-property (sheet-direct-mirror (event-sheet event)) (selection-event-property event) @@ -1364,8 +1371,10 @@ (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) -; (describe event *trace-output*) -; (finish-output *trace-output*) + (when (null property) + (format *trace-output* "~&* Requestor property is null! *~%")) + (describe event *trace-output*) + (finish-output *trace-output*) (cond ((member target '(:UTF8_STRING :STRING :TEXT)) (xlib:change-property requestor property (utf-8-encode

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14599 Modified Files: presentation-defs.lisp Log Message: Fix presentation system bug which produced incorrect results for presentation-type-of. Date: Sun Jan 2 06:28:38 2005 Author: ahefner Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.37 mcclim/presentation-defs.lisp:1.38 --- mcclim/presentation-defs.lisp:1.37 Sun Dec 5 20:37:52 2004 +++ mcclim/presentation-defs.lisp Sun Jan 2 06:28:38 2005 @@ -76,19 +76,20 @@ (let* ((name (class-name (class-of object))) (ptype-entry (gethash name *presentation-type-table*))) (unless ptype-entry - (return-from get-ptype-from-class-of name)) + (return-from get-ptype-from-class-of nil)) ;; Does the type have required parameters? If so, we can't use it... (let ((parameter-ll (parameters-lambda-list ptype-entry))) (values name (if (eq (car parameter-ll) '&whole) (cddr parameter-ll) - parameter-ll))))) + parameter-ll))))) (defmethod presentation-type-of ((object standard-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) - (if (or (null lambda-list) - (member lambda-list lambda-list-keywords)) + (if (and name + (or (null lambda-list) + (member (first lambda-list) lambda-list-keywords))) name (call-next-method))))

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14584 Modified Files: panes.lisp Log Message: Added comment in panes.lisp noting the the :x-spacing, :y-spacing, and :spacing initargs don't appear to work for grid and table panes. Date: Sun Jan 2 06:26:44 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.146 mcclim/panes.lisp:1.147 --- mcclim/panes.lisp:1.146 Tue Dec 7 05:49:51 2004 +++ mcclim/panes.lisp Sun Jan 2 06:26:44 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.146 2004/12/07 04:49:51 hefner1 Exp $ +;;; $Id: panes.lisp,v 1.147 2005/01/02 05:26:44 ahefner Exp $ (in-package :clim-internals) @@ -1343,6 +1343,9 @@ ) ;;; TABLE PANE + +;; TODO: The table and grid panes should respect the :x-spacing, +;; :y-spacing, and :spacing initargs. (defclass table-pane (composite-pane) ((array

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14568 Modified Files: gadgets.lisp Log Message: Fix incorrect default mode of list pane. Provide some tactile feedback by changing the pointer cursor within box-adjuster-gadget. Date: Sun Jan 2 06:25:38 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.85 mcclim/gadgets.lisp:1.86 --- mcclim/gadgets.lisp:1.85 Mon Nov 15 07:17:04 2004 +++ mcclim/gadgets.lisp Sun Jan 2 06:25:38 2005 @@ -46,9 +46,6 @@ ;; Why is there GADGET-LABEL-TEXT-STYLE? The spec says, that just the ;; pane's text-style should be borrowed. -;; Is "no label" as initarg to labelled gadget really such a good -;; idea? I would prefer "". - ;; RANGE-GADGET / RANGE-GADGET-MIXIN: same thing as with ;; ORIENTED-GADGET-MIXIN. @@ -1965,7 +1962,7 @@ (defclass meta-list-pane () ((mode :initarg :mode - :initform :some-of + :initform :exclusive :reader list-pane-mode :type (member :one-of :some-of)) (items :initarg :items @@ -2835,3 +2832,6 @@ (changing-space-requirements (:resize-frame nil) (adjust-space-requirement left-peer left-sr orientation delta) (adjust-space-requirement right-peer right-sr orientation (- delta))))))) + +(defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) + (setf (sheet-pointer-cursor sheet) :rotate))

1 0

[mcclim-cvs] CVS update: mcclim/bordered-output.lisp mcclim/dialog.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14532 Modified Files: bordered-output.lisp dialog.lisp Log Message: Add new :inset border shape. Use this to surround text fields created by accepting-values. Reduce offset of :drop-shadow border by one pixel, to three pixels. In accepting values dialogs, reclaim the space occupied by the dialog after exiting. Date: Sun Jan 2 06:24:50 2005 Author: ahefner Index: mcclim/bordered-output.lisp diff -u mcclim/bordered-output.lisp:1.12 mcclim/bordered-output.lisp:1.13 --- mcclim/bordered-output.lisp:1.12 Wed Oct 6 14:03:56 2004 +++ mcclim/bordered-output.lisp Sun Jan 2 06:24:49 2005 @@ -90,7 +90,7 @@ (define-border-type :drop-shadow (stream left top right bottom) (let* ((gap 3) ; FIXME? - (offset 4) + (offset 3) (left-edge (- left gap)) (bottom-edge (+ bottom gap)) (top-edge (- top gap)) @@ -108,13 +108,29 @@ :filled T))) (define-border-type :underline (stream record) - (labels ((fn (record) + (labels ((fn (record) (loop for child across (output-record-children record) do (typecase child (text-displayed-output-record (with-bounding-rectangle* (left top right bottom) child (declare (ignore top)) (draw-line* stream left bottom right bottom))) - (updating-output-record nil) + (updating-output-record nil) (compound-output-record (fn child)))))) (fn record))) + +(define-border-type :inset (stream left top right bottom) + (let* ((gap 3) + (left-edge (- left gap)) + (bottom-edge (+ bottom gap)) + (top-edge (- top gap)) + (right-edge (+ right gap)) + (dark *3d-dark-color*) + (light *3d-light-color*)) + (flet ((draw (left-edge right-edge bottom-edge top-edge light dark) + (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark) + (draw-line* stream left-edge top-edge right-edge top-edge :ink dark) + (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light) + (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light))) + (draw left-edge right-edge bottom-edge top-edge light dark) + (draw (1+ left-edge) (1- right-edge) (1- bottom-edge) (1+ top-edge) light dark)))) Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.14 mcclim/dialog.lisp:1.15 --- mcclim/dialog.lisp:1.14 Sun Oct 24 17:47:02 2004 +++ mcclim/dialog.lisp Sun Jan 2 06:24:49 2005 @@ -130,50 +130,53 @@ (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position - width height frame-class)) - (let* ((*accepting-values-stream* - (make-instance 'accepting-values-stream - :stream stream - :align-prompts align-prompts)) - (arecord (updating-output (stream - :record-type 'accepting-values-record) - (if align-prompts - (formatting-table (stream) - (funcall body *accepting-values-stream*)) - (funcall body *accepting-values-stream*)) - (display-exit-boxes *application-frame* - stream - (stream-default-view - *accepting-values-stream*)))) - (first-time t) - (current-command (if initially-select-p - `(com-select-query - ,initially-select-query-identifier) - *default-command*))) - (letf (((frame-command-table *application-frame*) - (find-command-table command-table))) - (unwind-protect - (handler-case - (loop - (if first-time - (setq first-time nil) - (when resynchronize-every-pass - (redisplay arecord stream))) - (with-input-context - ('(command :command-table accepting-values)) - (object) - (progn - (apply (command-name current-command) - (command-arguments current-command)) - ;; If current command returns without throwing a - ;; command, go back to the default command - (setq current-command *default-command*)) - (t (setq current-command object))) - (redisplay arecord stream)) - (av-exit () - (finalize-query-records *accepting-values-stream*) - (redisplay arecord stream))) - (erase-output-record arecord stream))))) + width height frame-class)) + (multiple-value-bind (cx cy) (stream-cursor-position stream) + (let* ((*accepting-values-stream* + (make-instance 'accepting-values-stream + :stream stream + :align-prompts align-prompts)) + (arecord (updating-output (stream + :record-type 'accepting-values-record) + (if align-prompts + (formatting-table (stream) + (funcall body *accepting-values-stream*)) + (funcall body *accepting-values-stream*)) + (display-exit-boxes *application-frame* + stream + (stream-default-view + *accepting-values-stream*)))) + (first-time t) + (current-command (if initially-select-p + `(com-select-query + ,initially-select-query-identifier) + *default-command*))) + (letf (((frame-command-table *application-frame*) + (find-command-table command-table))) + (unwind-protect + (handler-case + (loop + (if first-time + (setq first-time nil) + (when resynchronize-every-pass + (redisplay arecord stream))) + (with-input-context + ('(command :command-table accepting-values)) + (object) + (progn + (apply (command-name current-command) + (command-arguments current-command)) + ;; If current command returns without throwing a + ;; command, go back to the default command + (setq current-command *default-command*)) + (t (setq current-command object))) + (redisplay arecord stream)) + (av-exit () + (finalize-query-records *accepting-values-stream*) + (redisplay arecord stream))) + (erase-output-record arecord stream) + (setf (stream-cursor-position stream) + (values cx cy))))))) (defgeneric display-exit-boxes (frame stream view)) @@ -355,7 +358,7 @@ (with-output-as-presentation (stream query-identifier 'selectable-query) (surrounding-output-with-border - (stream :shape :drop-shadow :move-cursor t) + (stream :shape :inset :move-cursor t) (setq editing-stream (make-instance 'standard-input-editing-stream :stream stream

1 0

[mcclim-cvs] CVS update: mcclim/system.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14488 Modified Files: system.lisp Log Message: Migrate listener system definition into McCLIM/system.lisp. It should now be possible to load the listener by loading McCLIM/system.lisp then loading the clim-listener system and at least one backend system (such as clim-clx). This obsoletes clim-listener.asd. Date: Sun Jan 2 06:18:00 2005 Author: ahefner Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.106 mcclim/system.lisp:1.107 --- mcclim/system.lisp:1.106 Mon Dec 20 16:49:49 2004 +++ mcclim/system.lisp Sun Jan 2 06:17:59 2005 @@ -250,3 +250,14 @@ "Apps/Scigraph/scigraph/frame" "Apps/Scigraph/scigraph/export" "Apps/Scigraph/scigraph/demo-frame") + +(clim-defsystem (:clim-listener :depends-on (:clim #+clx :clim-looks #+sbcl :sb-posix)) + "Experimental/xpm" + "Apps/Listener/package" + "Apps/Listener/hotfixes" + "Apps/Listener/util" + "Apps/Listener/icons.lisp" + "Apps/Listener/file-types" + "Apps/Listener/dev-commands" + "Apps/Listener/listener" + #+CMU "Apps/Listener/cmu-hacks")

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/icons.lisp mcclim/Apps/Listener/listener.lisp mcclim/Apps/Listener/util.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13750 Modified Files: dev-commands.lisp icons.lisp listener.lisp util.lisp Log Message: Added additional presentation translators to the listener to make class metaobjects and class names more interchangable (thanks to someone on IRC, I've forgotten who, very sorry..). Also a bugfix where class names were potentially printed to the wrong stream. Adjust menu item names for entries in the listener show-commands table. Some cleanups to the listener wholine-pane, and addition of a spiffy 3D background. Date: Sun Jan 2 06:14:28 2005 Author: ahefner Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.27 mcclim/Apps/Listener/dev-commands.lisp:1.28 --- mcclim/Apps/Listener/dev-commands.lisp:1.27 Mon Dec 20 16:44:47 2004 +++ mcclim/Apps/Listener/dev-commands.lisp Sun Jan 2 06:14:28 2005 @@ -384,10 +384,51 @@ (room)) (define-presentation-to-command-translator mem-room-translator - (lisp-memory-usage com-room lisp-commands :gesture :select) + (lisp-memory-usage com-room lisp-commands + :gesture :select + :documentation "Room" + :pointer-documentation "Room") ()) +(define-presentation-to-command-translator com-show-class-subclasses-translator + (class-name com-show-class-subclasses lisp-commands + :menu t + :documentation "Show Class Subclasses" + :pointer-documentation "Show Class Subclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-superclasses-translator + (class-name com-show-class-superclasses lisp-commands + :menu t + :tester ((presentation) + (not (eq t (presentation-object presentation)))) + :documentation "Show Class Superclasses" + :pointer-documentation "Show Class Superclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-generic-functions-translator + (class-name com-show-class-generic-functions lisp-commands + :menu t + :documentation "Show Class Generic Functions" + :pointer-documentation "Show Class Generic Functions") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-slots-translator + (class-name com-show-class-slots lisp-commands + :menu t + :documentation "Show Class Slots" + :pointer-documentation "Show Class Slots") + (presentation) + (list (presentation-object presentation))) + + ;;; CLOS introspection commands (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) @@ -407,7 +448,7 @@ ;; class object itself is rather long and freaks out the pointer doc pane. (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) ; (surrounding-output-with-border (stream :shape :drop-shadow) - (princ (clim-mop:class-name class))))) ;) + (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream :merge-duplicates T @@ -425,7 +466,7 @@ (define-command (com-show-class-superclasses :name "Show Class Superclasses" :command-table show-commands - :menu t + :menu "Class Superclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -435,7 +476,7 @@ (define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands - :menu t + :menu "Class Subclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -551,7 +592,7 @@ (defun print-slot-table-heading () (formatting-row (T) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) + (formatting-cell (T :align-x :center) (underlining (T) (with-text-family (T :sans-serif) (princ name))))))) @@ -586,7 +627,7 @@ (define-command (com-show-class-slots :name "Show Class Slots" :command-table show-commands - :menu t + :menu "Class Slots" :provide-output-destination-keyword t) ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) @@ -652,7 +693,7 @@ (define-command (com-show-class-generic-functions :name "Show Class Generic Functions" :command-table show-commands - :menu t + :menu "Class Generic Functions" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -796,7 +837,7 @@ (define-command (com-show-generic-function :name t :command-table show-commands - :menu t + :menu "Generic Function" :provide-output-destination-keyword t) ((gf 'generic-function :prompt "a generic function") &key (classes 'boolean :default nil :mentioned-default t) @@ -936,7 +977,7 @@ (define-command (com-show-used-packages :name "Show Used Packages" :command-table show-commands - :menu t + :menu "Used Packages" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -949,7 +990,7 @@ (define-command (com-show-package-users :name "Show Package Users" :command-table show-commands - :menu t + :menu "Package Users" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -1388,7 +1429,9 @@ ;;; Some CLIM developer commands -(define-command (com-show-command-table :name t :menu t :command-table show-commands) +(define-command (com-show-command-table :name t + :menu "Command Table" + :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key (locally 'boolean :default nil :mentioned-default t) @@ -1407,7 +1450,8 @@ (push (cons ct (sort commands (lambda (x y) (string-lessp (command-line-name-for-command x ct :errorp :create) - (command-line-name-for-command y ct :errorp :create))))) our-tables))) + (command-line-name-for-command y ct :errorp :create))))) + our-tables))) (setq our-tables (nreverse our-tables)) (when show-commands ;; sure, why not? Index: mcclim/Apps/Listener/icons.lisp diff -u mcclim/Apps/Listener/icons.lisp:1.2 mcclim/Apps/Listener/icons.lisp:1.3 --- mcclim/Apps/Listener/icons.lisp:1.2 Mon Sep 29 22:33:03 2003 +++ mcclim/Apps/Listener/icons.lisp Sun Jan 2 06:14:28 2005 @@ -33,7 +33,8 @@ ;(defparameter *icon-path* (merge-pathnames #P"icons/" #.*compile-file-truename*)) (defmacro deficon (var pathname) - `(defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*)))) + `(eval-when (:load-toplevel :execute) + (defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*))))) (defvar *icon-cache* (make-hash-table :test #'equal)) Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.19 mcclim/Apps/Listener/listener.lisp:1.20 --- mcclim/Apps/Listener/listener.lisp:1.19 Mon Dec 20 16:45:34 2004 +++ mcclim/Apps/Listener/listener.lisp Sun Jan 2 06:14:28 2005 @@ -22,26 +22,21 @@ ;; Wholine Pane -(defclass wholine-pane (application-pane) ()) +(defclass wholine-pane (application-pane) () + (:default-initargs :background +gray90+)) (defmethod compose-space ((pane wholine-pane) &key width height) (declare (ignore width height)) - (let ((h (+ 3 (text-style-height (medium-text-style pane) pane)))) ; magic padding - (make-space-requirement :min-width 500 :width 768 ; magic space requirements - :height h - :min-height h - :max-height h))) - -(defvar *reconfiguring-wholine* nil) - -(defmethod allocate-space ((pane wholine-pane) width height) - (unless *reconfiguring-wholine* - (let ((*reconfiguring-wholine* t)) - (call-next-method) - (window-clear pane) - (redisplay-frame-pane (pane-frame pane) pane)))) - - + (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding + (make-space-requirement :height h + :min-height h + :max-height h))) + +;; When the pane is grown, we must repaint more than just the newly exposed +;; regions, because the decoration within the previous region must move. +;; Likewise, shrinking the pane requires repainting some of the interior. +(defmethod allocate-space :after ((pane wholine-pane) width height) + (repaint-sheet pane (sheet-region pane))) (defun print-package-name (stream) (let ((foo (package-name *package*))) @@ -53,7 +48,27 @@ (defun frob-pathname (pathname) (namestring (truename pathname))) -(defun display-wholine (frame pane) +;; How to add repaint-time decoration underneath the contents of a +;; stream pane: Write your own handle-repaint that draws the +;; decoration then replays the recorded output, and define a +;; window-clear method which calls the next window-clear method, +;; then calls handle-repaint to redraw the decoration. + +(defmethod handle-repaint ((pane wholine-pane) region) + (declare (ignore region)) + (with-output-recording-options (pane :draw t :record nil) + (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) + (climi::draw-bordered-rectangle* (sheet-medium pane) + x0 y0 x1 y1 + :style :mickey-mouse-inset) + #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) + (replay-output-record (stream-output-history pane) pane))) + +(defmethod window-clear ((pane wholine-pane)) + (call-next-method) + (handle-repaint pane (sheet-region pane))) + +(defun generate-wholine-contents (frame pane) (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) @@ -84,15 +99,19 @@ (format T " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters - ;; to really do so such that the memory usage appears right justified. + ;; to really do so such that the memory usage appears right justified. (cell (:center) (when (numberp memusage) (present memusage 'lisp-memory-usage))))))))) -;; This is a (very simple) command history. -;; Should we move this into CLIM-INTERNALS ? +(defun display-wholine (frame pane) + (invoke-and-center-output pane + (lambda () (generate-wholine-contents frame pane)) + :horizontally nil :hpad 5)) + +;; This is a toy command history. ;; Possibly this should become something integrated with the presentation -;; histories which I have not played with. +;; histories, which I have not played with. (defclass command-history-mixin () ((history :initform nil :accessor history) @@ -224,8 +243,6 @@ '(#$ #$ #\[ #\] #\# #\; #\: #\' #\" #\* #\, #\` #\- #\+ #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - - (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (if (system-command-reader frame) @@ -302,11 +319,15 @@ (defun run-listener (&key (system-command-reader nil) (new-process nil) + (width 800) + (height 800) (process-name "Listener") (eval nil)) (flet ((run () (run-frame-top-level (make-application-frame 'listener + :width width + :height height :system-command-reader system-command-reader) :listener-funcall (cond ((null eval) nil) ((functionp eval) eval) Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.15 mcclim/Apps/Listener/util.lisp:1.16 --- mcclim/Apps/Listener/util.lisp:1.15 Mon Dec 20 16:46:49 2004 +++ mcclim/Apps/Listener/util.lisp Sun Jan 2 06:14:28 2005 @@ -209,6 +209,26 @@ (- x (stream-cursor-position stream))) 0)) +(defun invoke-and-center-output (stream-pane continuation + &key (horizontally t) (vertically t) (hpad 0) (vpad 0)) + (let ((record (with-output-to-output-record (stream-pane) + (funcall continuation)))) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region stream-pane) + (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (bounding-rectangle record) + (setf (output-record-position record) + (values (if horizontally + (+ rx0 (/ (- (- sx1 sx0) + (- rx1 rx0)) + 2)) + (+ rx0 hpad)) + (if vertically + (+ ry0 (/ (- (- sy1 sy0) + (- ry1 ry0)) + 2)) + (+ ry0 vpad)))))) + (add-output-record record (stream-output-history stream-pane)) + (repaint-sheet stream-pane record))) + ;;; Pathname evil ;;; Fixme: Invent some more useful operators for manipulating pathnames, add a ;;; pinch of syntactic sugar, and cut the LOC here down to a fraction.

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/package.lisp
by ahefner＠common-lisp.net 01 Jan '05

01 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13715 Added Files: package.lisp Log Message: Package definition for listener. Date: Sun Jan 2 06:08:47 2005 Author: ahefner

1 0