July 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r188 - in trunk: docs/manual src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '06

09 Jul '06

Author: junrue Date: Sun Jul 9 12:03:27 2006 New Revision: 188 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp Log: removed rectangle argument from event-select and generated callbacks Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 12:03:27 2006 @@ -1084,7 +1084,7 @@ @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher widget rect +@deffn GenericFunction event-select dispatcher widget Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. @@ -1092,8 +1092,6 @@ @event-dispatcher-arg @item widget The @ref{widget} (or item) that was selected. -@item rect -The @ref{rectangle} bounding the selection inside @var{widget}. @end table @end deffn Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 12:03:27 2006 @@ -44,15 +44,15 @@ (declare (ignore disp)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) -(defun textedit-file-new (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-new (disp item) + (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) (setf (file-path *textedit-model*) nil))) -(defun textedit-file-open (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-open (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*textedit-win* '(:open :add-to-recent :path-must-exist) paths @@ -61,14 +61,14 @@ (load-textedit-doc (first paths)) (setf (file-path *textedit-model*) (namestring (first paths)))))) -(defun textedit-file-save (disp item rect) +(defun textedit-file-save (disp item) (if (file-path *textedit-model*) (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) - (textedit-file-save-as disp item rect)) + (textedit-file-save-as disp item)) (setf (gfw:text-modified-p *textedit-control*) nil)) -(defun textedit-file-save-as (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-save-as (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*textedit-win* '(:save :add-to-recent) paths @@ -79,15 +79,15 @@ (setf (file-path *textedit-model*) (namestring (first paths))) (setf (gfw:text-modified-p *textedit-control*) nil)))) -(defun textedit-file-quit (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-quit (disp item) + (declare (ignore disp item)) (setf *textedit-control* nil) (gfs:dispose *textedit-win*) (setf *textedit-win* nil) (gfw:shutdown 0)) -(defun textedit-font (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-font (disp item) + (declare (ignore disp item)) (gfw:with-graphics-context (gc *textedit-control*) (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) (if font @@ -102,7 +102,7 @@ (defmethod gfw:event-close ((disp textedit-win-events) window) (declare (ignore window)) - (textedit-file-quit disp nil nil)) + (textedit-file-quit disp nil)) (defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) @@ -110,8 +110,8 @@ (call-next-method) (gfs:dispose dlg)) -(defun about-textedit (disp item rect) - (declare (ignore disp item rect)) +(defun about-textedit (disp item) + (declare (ignore disp item)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) @@ -152,8 +152,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 9 12:03:27 2006 @@ -52,14 +52,14 @@ (defun get-scoreboard-panel () *scoreboard-panel*) -(defun new-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun new-unblocked (disp item) + (declare (ignore disp item)) (new-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) -(defun restart-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun restart-unblocked (disp item) + (declare (ignore disp item)) (restart-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) @@ -69,8 +69,8 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) -(defun reveal-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun reveal-unblocked (disp item) + (declare (ignore disp item)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) (when shape (let ((shape-pnts (shape-tile-points shape)) @@ -80,8 +80,8 @@ (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) (gfw:enable timer t))))) -(defun quit-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun quit-unblocked (disp item) + (declare (ignore disp item)) (setf *scoreboard-panel* nil) (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) @@ -92,7 +92,7 @@ (defmethod gfw:event-close ((disp unblocked-win-events) window) (declare (ignore window)) - (quit-unblocked disp nil nil)) + (quit-unblocked disp nil)) (defmethod gfw:event-timer ((disp unblocked-win-events) timer) (declare (ignore timer)) @@ -104,8 +104,8 @@ (call-next-method) (gfs:dispose dlg)) -(defun about-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun about-unblocked (disp item) + (declare (ignore disp item)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) @@ -146,8 +146,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" @@ -203,7 +203,7 @@ (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size)) - (new-unblocked nil nil nil) + (new-unblocked nil nil) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 12:03:27 2006 @@ -50,8 +50,8 @@ (setf *last-checked-drawing-item* item) (return))))) -(defun drawing-exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun drawing-exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *drawing-win*) (setf *drawing-win* nil) (gfw:shutdown 0)) @@ -63,7 +63,7 @@ (defmethod gfw:event-close ((self drawing-win-events) window) (declare (ignore window)) - (drawing-exit-fn self nil nil)) + (drawing-exit-fn self nil)) (defmethod gfw:event-paint ((self drawing-win-events) window gc rect) (declare (ignore rect)) @@ -162,8 +162,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) -(defun select-arcs (disp item rect) - (declare (ignore disp rect)) +(defun select-arcs (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) @@ -185,8 +185,8 @@ (setf (gfg:pen-style gc) '(:dot :square-endcap)) (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts)))) -(defun select-beziers (disp item rect) - (declare (ignore disp rect)) +(defun select-beziers (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) @@ -202,8 +202,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) -(defun select-ellipses (disp item rect) - (declare (ignore disp rect)) +(defun select-ellipses (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) (gfw:redraw *drawing-win*)) @@ -240,8 +240,8 @@ #'gfg:draw-line nil))) -(defun select-lines (disp item rect) - (declare (ignore disp rect)) +(defun select-lines (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) (gfw:redraw *drawing-win*)) @@ -264,8 +264,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) -(defun select-rects (disp item rect) - (declare (ignore disp rect)) +(defun select-rects (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) @@ -314,8 +314,8 @@ (setf (gfg:foreground-color gc) gfg:*color-red*) (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent)))) -(defun select-text (disp item rect) - (declare (ignore disp rect)) +(defun select-text (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) (gfw:redraw *drawing-win*)) @@ -336,8 +336,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) -(defun select-wedges (disp item rect) - (declare (ignore disp rect)) +(defun select-wedges (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 12:03:27 2006 @@ -184,8 +184,8 @@ (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect) - (declare (ignore item rect)) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item) + (declare (ignore item)) (exit-event-tester)) (defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item) @@ -194,8 +194,7 @@ (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item) (setf *event-tester-text* (text-for-item (gfw:text item) "item selected")) (gfw:redraw *event-tester-window*)) @@ -217,8 +216,8 @@ (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) -(defun manage-timer (disp item rect) - (declare (ignore disp item rect)) +(defun manage-timer (disp item) + (declare (ignore disp item)) (if *timer* (progn (gfw:enable *timer* nil) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Jul 9 12:03:27 2006 @@ -37,15 +37,15 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defun exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-close ((disp hellowin-events) window) (declare (ignore window)) - (exit-fn disp nil nil)) + (exit-fn disp nil)) (defmethod gfw:event-paint ((disp hellowin-events) window gc rect) (declare (ignore rect)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Jul 9 12:03:27 2006 @@ -86,8 +86,8 @@ (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) -(defun exit-image-fn (disp item rect) - (declare (ignorable disp item rect)) +(defun exit-image-fn (disp item) + (declare (ignorable disp item)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 12:03:27 2006 @@ -58,8 +58,8 @@ (defclass pack-layout-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect) - (declare (ignore item rect)) +(defmethod gfw:event-select ((d pack-layout-dispatcher) item) + (declare (ignore item)) (gfw:pack *layout-tester-win*)) (defclass layout-tester-widget-events (gfw:event-dispatcher) @@ -139,8 +139,7 @@ :dispatcher be)))) (incf *widget-counter*))) -(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d layout-tester-widget-events) btn) (setf (gfw:text btn) (funcall (toggle-fn d))) (gfw:layout *layout-tester-win*)) @@ -154,8 +153,8 @@ :initarg :subtype :initform :push-button))) -(defmethod gfw:event-select ((d add-child-dispatcher) item rect) - (declare (ignorable item rect)) +(defmethod gfw:event-select ((d add-child-dispatcher) item) + (declare (ignore item)) (add-layout-tester-widget (widget-class d) (subtype d)) (gfw:pack *layout-tester-win*)) @@ -191,8 +190,7 @@ (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d remove-child-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d remove-child-dispatcher) item) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) @@ -200,8 +198,7 @@ (defclass visibility-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) @@ -213,8 +210,8 @@ (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) -(defun set-flow-horizontal (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-horizontal (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) @@ -222,8 +219,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-vertical (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-vertical (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) @@ -231,8 +228,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-normalize (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-layout-normalize (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :normalize style) @@ -240,8 +237,8 @@ (setf (gfw:style-of layout) (push :normalize style))) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-wrap (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-layout-wrap (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) @@ -254,8 +251,8 @@ (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) -(defun decrease-flow-spacing (disp item rect) - (declare (ignore disp item rect)) +(defun decrease-flow-spacing (disp item) + (declare (ignore disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (spacing (gfw:spacing-of layout))) (unless (zerop spacing) @@ -263,76 +260,76 @@ (setf (gfw:spacing-of layout) spacing) (gfw:layout *layout-tester-win*)))) -(defun increase-flow-spacing (disp item rect) - (declare (ignore disp item rect)) +(defun increase-flow-spacing (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*))) -(defun enable-left-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-left-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) -(defun enable-top-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-top-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) -(defun enable-right-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-right-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) -(defun enable-bottom-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-bottom-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) -(defun inc-left-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-left-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-top-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-top-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-right-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-right-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-bottom-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-bottom-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-left-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-left-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-top-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-top-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-right-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-right-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-bottom-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-bottom-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) @@ -382,8 +379,8 @@ (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) -(defun exit-layout-callback (disp item rect) - (declare (ignorable disp item rect)) +(defun exit-layout-callback (disp item) + (declare (ignorable disp item)) (exit-layout-tester)) (defun run-layout-tester-internal () Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 9 12:03:27 2006 @@ -37,15 +37,15 @@ (defclass main-win-events (gfw:event-dispatcher) ()) -(defun windlg-exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun windlg-exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-close ((self main-win-events) window) (declare (ignore window)) - (windlg-exit-fn self nil nil)) + (windlg-exit-fn self nil)) (defclass test-win-events (gfw:event-dispatcher) ()) @@ -66,8 +66,8 @@ (declare (ignore point button)) (gfs:dispose window)) -(defun create-borderless-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-borderless-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:borderless)))) @@ -75,8 +75,8 @@ (gfw:center-on-owner window) (gfw:show window t))) -(defun create-miniframe-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-miniframe-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Mini Frame" @@ -85,8 +85,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun create-palette-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-palette-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Palette" @@ -95,8 +95,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun open-file-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-file-dlg (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*main-win* '(:open :add-to-recent :multiple-select) paths @@ -107,8 +107,8 @@ :text "Select Lisp-related files...") (print paths))) -(defun save-file-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun save-file-dlg (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*main-win* '(:save) paths @@ -117,8 +117,8 @@ :initial-directory #P"c:/") (print paths))) -(defun choose-font-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun choose-font-dlg (disp item) + (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) (gfw:with-font-dialog (*main-win* nil font color :gc gc) (if color @@ -198,15 +198,15 @@ :style '(:vertical :normalize)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Cancel" @@ -220,12 +220,12 @@ (gfw:show dlg t) dlg)) -(defun open-modal-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-modal-dlg (disp item) + (declare (ignore disp item)) (open-dlg "Modal" '(:owner-modal))) -(defun open-modeless-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-modeless-dlg (disp item) + (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 12:03:27 2006 @@ -48,10 +48,10 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) -(defgeneric event-collapse (dispatcher item rect) +(defgeneric event-collapse (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being collapsed.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-deactivate (dispatcher widget) (:documentation "Implement this to respond to an object being deactivated.") @@ -68,10 +68,10 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) -(defgeneric event-expand (dispatcher item rect) +(defgeneric event-expand (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being expanded.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-focus-gain (dispatcher widget) (:documentation "Implement this to respond to an object gaining keyboard focus.") @@ -173,10 +173,10 @@ (:method (dispatcher widget size type) (declare (ignorable dispatcher widget size type)))) -(defgeneric event-select (dispatcher item rect) +(defgeneric event-select (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being selected.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-show (dispatcher widget) (:documentation "Implement this to respond to an object being shown.") Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 12:03:27 2006 @@ -35,7 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) - (gfw:event-select . (gfw:event-source gfs:rectangle)))) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 12:03:27 2006 @@ -120,7 +120,7 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget (gfs:make-rectangle))) ; FIXME + (0 (event-select disp widget)) (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) (#.gfs::+en-update+ (event-modify disp widget))))) @@ -172,7 +172,7 @@ (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) - (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME + (event-select (dispatcher item) item))))) ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t

1 0

[graphic-forms-cvs] r187 - in trunk: docs/manual src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '06

09 Jul '06

Author: junrue Date: Sun Jul 9 11:30:38 2006 New Revision: 187 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: completed event-activate and added event-deactivate Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 11:30:38 2006 @@ -836,8 +836,9 @@ This chapter documents two types of functions: @itemize @bullet -@item generic functions implemented in order to handle system events -@item functions provided to help implement application message pumps +@item generic functions whose methods are to be implemented by application +code in order to handle system events +@item functions provided to help implement message loops @end itemize @anchor{default-message-filter} @@ -861,29 +862,19 @@ @end table @end defun -@deffn GenericFunction event-activate dispatcher widget type +@anchor{event-activate} +@deffn GenericFunction event-activate dispatcher widget Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and border) was highlighted to indicate that it is now the active window. For a @ref{menu}, it means that the user has clicked on the @ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. +an opportunity to update the menu's contents. @xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget The menu, dialog, or window that has been activated. -@item type -Provides a hint as to how activation occurred, via one of the following -keywords: -@table @code -@item :click -Indicates that @var{widget} was activated as the result of a mouse click. -@item :programmatic -Indicates that @var{widget} was activated as the result of the keyboard -interface to select a window, or programmatically via a call to -@sc{activate}. -@end table @end table @end deffn @@ -910,6 +901,19 @@ @end table @end deffn +@anchor{event-deactivate} +@deffn GenericFunction event-deactivate dispatcher widget +Implement this method to respond to @var{widget} being deactivated, +meaning that some other object has been made active. This event only +applies to @ref{top-level} @ref{window}s or +@ref{dialog}s. @xref{event-activate}. +@table @var +@event-dispatcher-arg +@item widget +The dialog or window that has been deactivated. +@end table +@end deffn + @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}, not collected via the garbage collector). This @@ -1089,7 +1093,7 @@ @item widget The @ref{widget} (or item) that was selected. @item rect -The @ref{rectangle} bounding @var{widget}. +The @ref{rectangle} bounding the selection inside @var{widget}. @end table @end deffn @@ -1123,7 +1127,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds Returns the timestamp for the event currently being processed, or -zero if called prior to the delivery of any events. +zero if called prior to delivery of any events. @end defun Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 11:30:38 2006 @@ -40,8 +40,8 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) -(defun manage-textedit-file-menu (disp menu type) - (declare (ignore disp type)) +(defun manage-textedit-file-menu (disp menu) + (declare (ignore disp)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) (defun textedit-file-new (disp item rect) @@ -95,15 +95,15 @@ (defclass textedit-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp textedit-win-events) window) - (declare (ignore window)) - (textedit-file-quit disp nil nil)) - -(defmethod gfw:event-focus-gain ((self textedit-win-events) window) +(defmethod gfw:event-activate ((self textedit-win-events) window) (declare (ignore window)) (if *textedit-control* (gfw:give-focus *textedit-control*))) +(defmethod gfw:event-close ((disp textedit-win-events) window) + (declare (ignore window)) + (textedit-file-quit disp nil nil)) + (defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 11:30:38 2006 @@ -42,8 +42,8 @@ (gfw:check *last-checked-drawing-item* nil)) (gfw:check item t)) -(defun find-checked-item (disp menu type) - (declare (ignore disp type)) +(defun find-checked-item (disp menu) + (declare (ignore disp)) (dotimes (i (length (gfw:items menu))) (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 11:30:38 2006 @@ -72,6 +72,14 @@ (not (gfw:key-toggled-p gfw:+vk-num-lock+)) (not (gfw:key-toggled-p gfw:+vk-scroll-lock+)))) +(defun text-for-activation (action) + (format nil + "~a action: ~s time: 0x~x ~s" + (incf *event-counter*) + action + (gfw:obtain-event-time) + (text-for-modifiers))) + (defun text-for-mouse (action button pnt) (format nil "~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s" @@ -128,7 +136,15 @@ (gfw:id-of *timer*) (gfw:obtain-event-time) (text-for-modifiers))) - + +(defmethod gfw:event-activate ((d event-tester-window-events) window) + (setf *event-tester-text* (text-for-activation "window activated")) + (gfw:redraw window)) + +(defmethod gfw:event-deactivate ((d event-tester-window-events) window) + (setf *event-tester-text* (text-for-activation "window deactivated")) + (gfw:redraw window)) + (defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char) (setf *event-tester-text* (text-for-key "down" key-code char)) (gfw:redraw window)) @@ -187,8 +203,7 @@ (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type) - (declare (ignore type)) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget) (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated")) (gfw:redraw *event-tester-window*)) @@ -197,8 +212,8 @@ (setf *event-tester-text* (text-for-timer)) (gfw:redraw *event-tester-window*)) -(defun manage-file-menu (disp menu type) - (declare (ignore disp type)) +(defun manage-file-menu (disp menu) + (declare (ignore disp)) (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 11:30:38 2006 @@ -169,8 +169,7 @@ :initarg :sub-disp-class :initform nil))) -(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type) - (declare (ignore type)) +(defmethod gfw:event-activate ((d child-menu-dispatcher) menu) (gfw:clear-all menu) (gfw:mapchildren *layout-tester-win* (lambda (parent child) @@ -208,8 +207,8 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defun check-flow-orient-items (disp menu type) - (declare (ignore disp type)) +(defun check-flow-orient-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) @@ -250,8 +249,8 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) -(defun enable-flow-spacing-items (disp menu type) - (declare (ignore disp type)) +(defun enable-flow-spacing-items (disp menu) + (declare (ignore disp)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) @@ -338,8 +337,8 @@ (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun flow-mod-callback (disp menu type) - (declare (ignore disp type)) +(defun flow-mod-callback (disp menu) + (declare (ignore disp)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenu ((:item "Left" Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jul 9 11:30:38 2006 @@ -146,8 +146,7 @@ (error 'gfs:disposed-error))) (defmethod give-focus ((self control)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle self))) - (error 'gfs:win32-error :detail "set-focus failed"))) + (gfs::set-focus (gfs:handle self))) (defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 11:30:38 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric event-activate (dispatcher widget type) +(defgeneric event-activate (dispatcher widget) (:documentation "Implement this to respond to an object being activated.") - (:method (dispatcher widget type) - (declare (ignorable dispatcher widget type)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) (defgeneric event-arm (dispatcher item) (:documentation "Implement this to respond to an object about to be selected.") @@ -53,10 +53,10 @@ (:method (dispatcher item rect) (declare (ignorable dispatcher item rect)))) -(defgeneric event-deactivate (dispatcher widget type) +(defgeneric event-deactivate (dispatcher widget) (:documentation "Implement this to respond to an object being deactivated.") - (:method (dispatcher widget type) - (declare (ignorable dispatcher widget type)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 11:30:38 2006 @@ -33,7 +33,7 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol)) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) (gfw:event-select . (gfw:event-source gfs:rectangle)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 11:30:38 2006 @@ -190,7 +190,7 @@ (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too + (event-activate d menu))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) @@ -349,18 +349,26 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-activate+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (ecase wparam + (#.gfs::+wa-active+ (event-activate (dispatcher widget) widget)) + (#.gfs::+wa-clickactive+ (event-activate (dispatcher widget) widget)) + (#.gfs::+wa-inactive+ (event-deactivate (dispatcher widget) widget))))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-killfocus+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (event-focus-loss (dispatcher widget) widget))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (event-focus-gain (dispatcher widget) widget))) 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 9 11:30:38 2006 @@ -199,8 +199,7 @@ (error 'gfs:disposed-error))) (defmethod give-focus ((win window)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) - (error 'gfs:win32-error :detail "set-focus failed"))) + (gfs::set-focus (gfs:handle win))) (defmethod location ((win window)) (if (gfs:disposed-p win)

1 0

[graphic-forms-cvs] r186 - in trunk: docs/manual src src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '06

09 Jul '06

Author: junrue Date: Sun Jul 9 02:35:37 2006 New Revision: 186 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored event-*** functions by removing time argument - call OBTAIN-EVENT-TIME instead now; added type argument to event-activate; significantly enhanced documentation of event functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 02:35:37 2006 @@ -834,112 +834,297 @@ @node event functions @section event functions +This chapter documents two types of functions: +@itemize @bullet +@item generic functions implemented in order to handle system events +@item functions provided to help implement application message pumps +@end itemize + @anchor{default-message-filter} -@deffn Function default-message-filter gm-code msg-ptr +@defun default-message-filter gm-code msg-ptr Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and @ref{control}s. Accelerator keys are also translated by this function. Returns @sc{nil} so that @ref{message-loop} will continue, -unless @code{gm-code} is less than or equal to zero, in which case +unless @var{gm-code} is less than or equal to zero, in which case @sc{t} is returned so that @ref{message-loop} will exit. When -@code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT} -message indicating normal shutdown. If @code{gm-code} is -1, then the -system has reported an error during message retrieval which should be -handled by (hopefully) graceful shutdown. -@end deffn +@var{gm-code} is zero, @var{msg-ptr} identifies a @sc{WM_QUIT} +message indicating normal shutdown. If @var{gm-code} is -1, then the +system has reported an error during message retrieval; in this +situation, the application should attempt a graceful shutdown. +@table @var +@item gm-code +The code returned by the @code{GetMessage} Win32 @sc{api} call. +@item msg-ptr +A pointer to a Win32 @sc{api} @code{MSG} data structure, filled in +by @code{GetMessage} and containing raw event data to be +translated and dispatched. +@end table +@end defun -@deffn GenericFunction event-activate dispatcher widget time -Implement this to respond to an object being activated. +@deffn GenericFunction event-activate dispatcher widget type +Implement this method to respond to @var{widget} being activated. For +a @ref{top-level} @ref{window} or @ref{dialog}, this means that +@var{widget} was brought to the foreground and its trim (titlebar and +border) was highlighted to indicate that it is now the active +window. For a @ref{menu}, it means that the user has clicked on the +@ref{item} invoking @ref{widget} and it is about to be shown; this is +an opportunity to update the menu's contents. +@table @var +@event-dispatcher-arg +@item widget +The menu, dialog, or window that has been activated. +@item type +Provides a hint as to how activation occurred, via one of the following +keywords: +@table @code +@item :click +Indicates that @var{widget} was activated as the result of a mouse click. +@item :programmatic +Indicates that @var{widget} was activated as the result of the keyboard +interface to select a window, or programmatically via a call to +@sc{activate}. +@end table +@end table @end deffn -@deffn GenericFunction event-arm dispatcher item time -Implement this to respond to an object about to be selected. +@deffn GenericFunction event-arm dispatcher item +Implement this method to respond to the prior notice of @var{item} +being selected. Of course, an arm event is not necessarily always +followed by a selection, such as if the user moves the mouse across +items on a @ref{menu}. +@table @var +@event-dispatcher-arg +@item item +The @ref{item} about to be selected. +@end table @end deffn -@deffn GenericFunction event-close dispatcher widget time -Implement this to respond to an object being closed. +@deffn GenericFunction event-close dispatcher widget +Implement this method to respond to @var{widget} being closed by the user. +Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close +events. +@table @var +@event-dispatcher-arg +@item widget +The dialog or window being closed. +@end table @end deffn -@deffn GenericFunction event-dispose dispatcher widget time -Implement this to respond to an object being disposed (via -@ref{dispose}, not the garbage collector). +@deffn GenericFunction event-dispose dispatcher widget +Implement this method to respond to @var{widget} being disposed (explicitly +via @ref{dispose}, not collected via the garbage collector). This +event function is called while the contents of @var{widget} are still +valid. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} being disposed. +@end table @end deffn @anchor{event-focus-gain} -@deffn GenericFunction event-focus-gain dispatcher widget time -Implement this to respond to an object gaining keyboard focus. +@deffn GenericFunction event-focus-gain dispatcher widget +Implement this method to respond to @var{widget} gaining keyboard focus. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} gaining keyboard focus. +@end table @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-loss dispatcher widget time -Implement this to respond to an object losing keyboard focus. +@deffn GenericFunction event-focus-loss dispatcher widget +Implement this method to respond to @var{widget} losing keyboard focus. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} losing keyboard focus. +@end table @end deffn -@deffn GenericFunction event-key-down dispatcher widget time keycode char -Implement this to respond to a key down event. +@deffn GenericFunction event-key-down dispatcher widget keycode char +Implement this method to respond to a key being pressed within +@var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} in which the key was pressed. +@item keycode +The virtual key code of the key that was pressed. +@item char +The character value resulting from translation of the virtual key code, +or @sc{nil} if the key code cannot be translated. +@end table @end deffn -@deffn GenericFunction event-key-up dispatcher widget time keycode char -Implement this to respond to a key up event. +@deffn GenericFunction event-key-up dispatcher widget keycode char +Implement this method to respond to a key being released within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} in which the key was released. +@item keycode +The virtual key code of the key that was released. +@item char +The character value resulting from translation of the virtual key code, +or @sc{nil} if the key code cannot be translated. +@end table @end deffn @anchor{event-modify} -@deffn GenericFunction event-modify dispatcher widget time -Implement this to respond to changes within a @ref{widget}, for example -when the user types text inside an @ref{edit} control. +@deffn GenericFunction event-modify dispatcher widget +Implement this method to respond to changes due to user input within +@ref{widget}, for example when the user types text inside an +@ref{edit} @ref{control}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} that was modified by the user. +@end table @end deffn -@deffn GenericFunction event-mouse-double dispatcher widget time point button -Implement this to respond to a mouse double-click. +@deffn GenericFunction event-mouse-double dispatcher widget point button +Implement this method to respond to a mouse button double-click within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was double-clicked. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn -@deffn GenericFunction event-mouse-down dispatcher widget time point button -Implement this to respond to a mouse down event. +@deffn GenericFunction event-mouse-down dispatcher widget point button +Implement this method to respond to a mouse button click within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was clicked. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn -@deffn GenericFunction event-mouse-move dispatcher widget time point button -Implement this to respond to a mouse move event. +@deffn GenericFunction event-mouse-move dispatcher widget point button +Implement this method to respond to a mouse move event within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was moved. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn -@deffn GenericFunction event-mouse-up dispatcher widget time point button -Implement this to respond to a mouse up event. +@deffn GenericFunction event-mouse-up dispatcher widget point button +Implement this method to respond to a mouse button being released within +@var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse button was released. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn -@deffn GenericFunction event-move dispatcher widget time point -Implement this to respond to an object being moved within its parent's -coordinate system. +@deffn GenericFunction event-move dispatcher widget point +Implement this method to respond to @var{widget} being moved within its +@ref{parent}'s coordinate system. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} being moved. +@item point +The destination @ref{point} to which @var{widget} was moved. +@end table @end deffn @anchor{event-paint} -@deffn GenericFunction event-paint dispatcher widget time gc rect -Implement this to respond to paint requests. +@deffn GenericFunction event-paint dispatcher widget gc rect +Implement this method to respond to system requests to repaint @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} whose contents need to be repainted. +@item gc +A @ref{graphics-context} initialized for use during this paint event and +which will be @ref{dispose}d after this method returns. +@item rect +The specific @ref{rectangle} within @var{widget} needing to be repainted. +@end table @end deffn -@deffn GenericFunction event-resize dispatcher widget time size type -Implement this to respond to an object being resized. +@deffn GenericFunction event-resize dispatcher widget size type +Implement this method to respond to @var{widget} being resized. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} whose dimensions are being changed. +@item size +A @ref{size} object describing @var{widget}'s new dimensions. +@item type +Identifies three different kinds of resizing actions: +@table @code +@item :maximized +Indicates that @var{widget} was expanded to its maximum size, such as +when the user clicks on the maximize button in a @ref{window} frame. +@item :minimized +Indicates that @var{widget} was minimized to the taskbar. +@item :restored +Indicates that @var{widget} was either restored from a minimized +state, or that resizing occurred while @var{widget} was already +in a visible, non-maximized state. +@end table +@end table @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher item time rect -Implement this to respond to an object (or item within) being selected. +@deffn GenericFunction event-select dispatcher widget rect +Implement this method to handle notification that @var{widget} (or some +@ref{item} within @var{widget}) has been clicked on by the user in order +to invoke some action. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} (or item) that was selected. +@item rect +The @ref{rectangle} bounding @var{widget}. +@end table @end deffn @anchor{event-timer} -@deffn GenericFunction event-timer dispatcher timer time -Implement this to respond to a tick from a specific timer. +@deffn GenericFunction event-timer dispatcher timer +Implement this method to respond to expiration of the current +delay configured for @var{timer}. +@table @var +@event-dispatcher-arg +@item timer +The @ref{timer} that generated this event. +@end table @end deffn @anchor{message-loop} -@deffn Function message-loop msg-filter +@defun message-loop msg-filter This function retrieves messages from the system with the intent of -passing each one to the function specified by @code{msg-filter} so +passing each one to the function specified by @var{msg-filter} so that it may be translated and dispatched. The return value of the -@code{msg-filter} function determines whether @code{message-loop} -continues or returns, and this termination condition depends on the -context of the message loop being executed. The return value is -@sc{nil} if @code{message-loop} should continue, or not @sc{nil} if -the loop should exit. The pre-defined implementation -@ref{default-message-filter} is provided. -@end deffn +@var{msg-filter} function determines whether @code{message-loop} +continues or returns. The return value must be @sc{nil} if +@code{message-loop} should continue, or not @sc{nil} if the +loop should exit. +@table @var +@item msg-filter +A @sc{function} object; see @ref{default-message-filter} for more +details. +@end table +@end defun + +@anchor{obtain-event-time} +@defun obtain-event-time => milliseconds +Returns the timestamp for the event currently being processed, or +zero if called prior to the delivery of any events. +@end defun @node widget functions Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun Jul 9 02:35:37 2006 @@ -75,6 +75,31 @@ @end quotation @end macro +@macro event-dispatcher-arg +@item dispatcher +The @ref{event-dispatcher} to process this event. +@end macro + +@macro event-mouse-button-arg +@item button +A keyword identifying which mouse button was used: +@table @code +@item :left-button +@item :middle-button +@item :right-button +@end table +@end macro + +@macro event-mouse-point-arg +@item point +The @ref{point} location of the mouse cursor. +@end macro + +@macro event-time-arg +@item time +This event's timestamp in milliseconds. +@end macro + @c Info "requires" that x-refs end in a period or comma, or ) in the @c case of @pxref. So the following implements that requirement for @c the "See also" subheadings that permeate this manual, but only in Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 02:35:37 2006 @@ -40,19 +40,19 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) -(defun manage-textedit-file-menu (disp menu time) - (declare (ignore disp time)) +(defun manage-textedit-file-menu (disp menu type) + (declare (ignore disp type)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) -(defun textedit-file-new (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-new (disp item rect) + (declare (ignore disp item rect)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) (setf (file-path *textedit-model*) nil))) -(defun textedit-file-open (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-open (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*textedit-win* '(:open :add-to-recent :path-must-exist) paths @@ -61,14 +61,14 @@ (load-textedit-doc (first paths)) (setf (file-path *textedit-model*) (namestring (first paths)))))) -(defun textedit-file-save (disp item time rect) +(defun textedit-file-save (disp item rect) (if (file-path *textedit-model*) (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) - (textedit-file-save-as disp item time rect)) + (textedit-file-save-as disp item rect)) (setf (gfw:text-modified-p *textedit-control*) nil)) -(defun textedit-file-save-as (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-save-as (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*textedit-win* '(:save :add-to-recent) paths @@ -79,15 +79,15 @@ (setf (file-path *textedit-model*) (namestring (first paths))) (setf (gfw:text-modified-p *textedit-control*) nil)))) -(defun textedit-file-quit (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-quit (disp item rect) + (declare (ignore disp item rect)) (setf *textedit-control* nil) (gfs:dispose *textedit-win*) (setf *textedit-win* nil) (gfw:shutdown 0)) -(defun textedit-font (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-font (disp item rect) + (declare (ignore disp item rect)) (gfw:with-graphics-context (gc *textedit-control*) (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) (if font @@ -95,24 +95,23 @@ (defclass textedit-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp textedit-win-events) window time) - (declare (ignore window time)) - (textedit-file-quit disp nil nil nil)) +(defmethod gfw:event-close ((disp textedit-win-events) window) + (declare (ignore window)) + (textedit-file-quit disp nil nil)) -(defmethod gfw:event-focus-gain ((self textedit-win-events) window time) - (declare (ignore window time)) +(defmethod gfw:event-focus-gain ((self textedit-win-events) window) + (declare (ignore window)) (if *textedit-control* (gfw:give-focus *textedit-control*))) (defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) +(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg)) -(defun about-textedit (disp item time rect) - (declare (ignore disp item time rect)) +(defun about-textedit (disp item rect) + (declare (ignore disp item rect)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) @@ -153,8 +152,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Jul 9 02:35:37 2006 @@ -60,6 +60,6 @@ (defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size) (setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size))) -(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect) - (declare (ignore window time rect)) +(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window gc rect) + (declare (ignore window rect)) (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jul 9 02:35:37 2006 @@ -94,8 +94,7 @@ (setf (gethash kind table) image) (incf kind))))) -(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) - (declare (ignore time)) +(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button) (let* ((tiles (game-tiles)) (tile-pnt (window->tiles point)) (tile-kind (obtain-tile tiles tile-pnt)) @@ -114,8 +113,7 @@ (setf (shape-pnts-of self) (shape-tile-points tmp-table)) (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) -(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) - (declare (ignore time)) +(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button) (gfw:release-mouse) (let ((tile-pnt (window->tiles point)) (shape-pnts (shape-pnts-of self))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 9 02:35:37 2006 @@ -52,14 +52,14 @@ (defun get-scoreboard-panel () *scoreboard-panel*) -(defun new-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun new-unblocked (disp item rect) + (declare (ignore disp item rect)) (new-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) -(defun restart-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun restart-unblocked (disp item rect) + (declare (ignore disp item rect)) (restart-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) @@ -69,8 +69,8 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) -(defun reveal-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun reveal-unblocked (disp item rect) + (declare (ignore disp item rect)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) (when shape (let ((shape-pnts (shape-tile-points shape)) @@ -80,8 +80,8 @@ (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) (gfw:enable timer t))))) -(defun quit-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun quit-unblocked (disp item rect) + (declare (ignore disp item rect)) (setf *scoreboard-panel* nil) (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) @@ -90,23 +90,22 @@ (defclass unblocked-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp unblocked-win-events) window time) - (declare (ignore window time)) - (quit-unblocked disp nil nil nil)) +(defmethod gfw:event-close ((disp unblocked-win-events) window) + (declare (ignore window)) + (quit-unblocked disp nil nil)) -(defmethod gfw:event-timer ((disp unblocked-win-events) timer time) - (declare (ignore timer time)) +(defmethod gfw:event-timer ((disp unblocked-win-events) timer) + (declare (ignore timer)) (update-panel *tiles-panel*)) (defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) +(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg)) -(defun about-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun about-unblocked (disp item rect) + (declare (ignore disp item rect)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) @@ -147,8 +146,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" @@ -204,7 +203,7 @@ (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size)) - (new-unblocked nil nil nil nil) + (new-unblocked nil nil nil) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jul 9 02:35:37 2006 @@ -441,6 +441,7 @@ #:moveable-p #:object-to-display #:obtain-displays + #:obtain-event-time #:obtain-primary-display #:owner #:pack Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 02:35:37 2006 @@ -42,16 +42,16 @@ (gfw:check *last-checked-drawing-item* nil)) (gfw:check item t)) -(defun find-checked-item (disp menu time) - (declare (ignore disp time)) +(defun find-checked-item (disp menu type) + (declare (ignore disp type)) (dotimes (i (length (gfw:items menu))) (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return))))) -(defun drawing-exit-fn (disp item time rect) - (declare (ignore disp item time rect)) +(defun drawing-exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *drawing-win*) (setf *drawing-win* nil) (gfw:shutdown 0)) @@ -61,12 +61,12 @@ :accessor draw-func-of :initform nil))) -(defmethod gfw:event-close ((self drawing-win-events) window time) - (declare (ignore window time)) - (drawing-exit-fn self nil nil 0)) +(defmethod gfw:event-close ((self drawing-win-events) window) + (declare (ignore window)) + (drawing-exit-fn self nil nil)) -(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((self drawing-win-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) @@ -162,8 +162,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) -(defun select-arcs (disp item time rect) - (declare (ignore disp time rect)) +(defun select-arcs (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) @@ -185,8 +185,8 @@ (setf (gfg:pen-style gc) '(:dot :square-endcap)) (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts)))) -(defun select-beziers (disp item time rect) - (declare (ignore disp time rect)) +(defun select-beziers (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) @@ -202,8 +202,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) -(defun select-ellipses (disp item time rect) - (declare (ignore disp time rect)) +(defun select-ellipses (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) (gfw:redraw *drawing-win*)) @@ -240,8 +240,8 @@ #'gfg:draw-line nil))) -(defun select-lines (disp item time rect) - (declare (ignore disp time rect)) +(defun select-lines (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) (gfw:redraw *drawing-win*)) @@ -264,8 +264,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) -(defun select-rects (disp item time rect) - (declare (ignore disp time rect)) +(defun select-rects (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) @@ -314,8 +314,8 @@ (setf (gfg:foreground-color gc) gfg:*color-red*) (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent)))) -(defun select-text (disp item time rect) - (declare (ignore disp time rect)) +(defun select-text (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) (gfw:redraw *drawing-win*)) @@ -336,8 +336,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) -(defun select-wedges (disp item time rect) - (declare (ignore disp time rect)) +(defun select-wedges (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 02:35:37 2006 @@ -47,16 +47,16 @@ (defclass event-tester-window-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) - (declare (ignorable time rect)) +(defmethod gfw:event-paint ((d event-tester-window-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2)))) (gfg:draw-text gc *event-tester-text* pnt))) -(defmethod gfw:event-close ((d event-tester-window-events) widget time) - (declare (ignore widget time)) +(defmethod gfw:event-close ((d event-tester-window-events) widget) + (declare (ignore widget)) (exit-event-tester)) (defun text-for-modifiers () @@ -72,7 +72,7 @@ (not (gfw:key-toggled-p gfw:+vk-num-lock+)) (not (gfw:key-toggled-p gfw:+vk-scroll-lock+)))) -(defun text-for-mouse (action time button pnt) +(defun text-for-mouse (action button pnt) (format nil "~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) @@ -80,131 +80,130 @@ button (gfs:point-x pnt) (gfs:point-y pnt) - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defun text-for-key (action time key-code char) +(defun text-for-key (action key-code char) (format nil "~a key action: ~s char: ~s code: 0x~x time: 0x~x ~s" (incf *event-counter*) action char key-code - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defun text-for-item (text time desc) +(defun text-for-item (text desc) (format nil "~a ~s: ~s time: 0x~x ~s" (incf *event-counter*) desc text - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defun text-for-size (type time size) +(defun text-for-size (type size) (format nil "~a resize action: ~s size: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (symbol-name type) (gfs:size-width size) (gfs:size-height size) - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defun text-for-move (time pnt) +(defun text-for-move (pnt) (format nil "~a move point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (gfs:point-x pnt) (gfs:point-y pnt) - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defun text-for-timer (time) +(defun text-for-timer () (format nil "~a timer tick id: ~d time: 0x~x ~s" (incf *event-counter*) (gfw:id-of *timer*) - time + (gfw:obtain-event-time) (text-for-modifiers))) -(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char) - (setf *event-tester-text* (text-for-key "down" time key-code char)) +(defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char) + (setf *event-tester-text* (text-for-key "down" key-code char)) (gfw:redraw window)) -(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char) - (setf *event-tester-text* (text-for-key "up" time key-code char)) +(defmethod gfw:event-key-up ((d event-tester-window-events) window key-code char) + (setf *event-tester-text* (text-for-key "up" key-code char)) (gfw:redraw window)) -(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "double" time button pnt)) +(defmethod gfw:event-mouse-double ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "double" button pnt)) (gfw:redraw window)) -(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "down" time button pnt)) +(defmethod gfw:event-mouse-down ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "down" button pnt)) (setf *mouse-down-flag* t) (gfw:redraw window)) -(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button) +(defmethod gfw:event-mouse-move ((d event-tester-window-events) window pnt button) (when *mouse-down-flag* - (setf *event-tester-text* (text-for-mouse "move" time button pnt)) + (setf *event-tester-text* (text-for-mouse "move" button pnt)) (gfw:redraw window))) -(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "up" time button pnt)) +(defmethod gfw:event-mouse-up ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "up" button pnt)) (setf *mouse-down-flag* nil) (gfw:redraw window)) -(defmethod gfw:event-move ((d event-tester-window-events) window time pnt) - (setf *event-tester-text* (text-for-move time pnt)) +(defmethod gfw:event-move ((d event-tester-window-events) window pnt) + (setf *event-tester-text* (text-for-move pnt)) (gfw:redraw window) 0) -(defmethod gfw:event-resize ((d event-tester-window-events) window time size type) - (setf *event-tester-text* (text-for-size type time size)) +(defmethod gfw:event-resize ((d event-tester-window-events) window size type) + (setf *event-tester-text* (text-for-size type size)) (gfw:redraw window) 0) (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect) + (declare (ignore item rect)) (exit-event-tester)) -(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time) - (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) +(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item) + (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*)) (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect) (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected")) + (setf *event-tester-text* (text-for-item (gfw:text item) "item selected")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time) - (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) +(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item) + (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time) - (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated")) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type) + (declare (ignore type)) + (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time) - (declare (ignore disp timer)) - (setf *event-tester-text* (text-for-timer time)) +(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer) + (declare (ignore timer)) + (setf *event-tester-text* (text-for-timer)) (gfw:redraw *event-tester-window*)) -(defun manage-file-menu (disp menu time) - (declare (ignore disp time)) +(defun manage-file-menu (disp menu type) + (declare (ignore disp type)) (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) -(defun manage-timer (disp item time rect) - (declare (ignore disp item time rect)) +(defun manage-timer (disp item rect) + (declare (ignore disp item rect)) (if *timer* (progn (gfw:enable *timer* nil) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Jul 9 02:35:37 2006 @@ -37,18 +37,18 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defun exit-fn (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0)) -(defmethod gfw:event-close ((disp hellowin-events) window time) +(defmethod gfw:event-close ((disp hellowin-events) window) (declare (ignore window)) - (exit-fn disp nil time nil)) + (exit-fn disp nil nil)) -(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((disp hellowin-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Jul 9 02:35:37 2006 @@ -48,15 +48,15 @@ (gfs:dispose *true-image*) (setf *true-image* nil)) -(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defmethod gfw:event-close ((d image-events) window) + (declare (ignore window)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) -(defmethod gfw:event-paint ((d image-events) window time gc rect) - (declare (ignore window time rect)) +(defmethod gfw:event-paint ((d image-events) window gc rect) + (declare (ignore window rect)) (let ((pnt (gfs:make-point)) (pixel-pnt1 (gfs:make-point)) (pixel-pnt2 (gfs:make-point :x 0 :y 15))) @@ -86,8 +86,8 @@ (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) -(defun exit-image-fn (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-image-fn (disp item rect) + (declare (ignorable disp item rect)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 02:35:37 2006 @@ -52,14 +52,14 @@ (defclass layout-tester-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d layout-tester-events) widget time) - (declare (ignore widget time)) +(defmethod gfw:event-close ((d layout-tester-events) widget) + (declare (ignore widget)) (exit-layout-tester)) (defclass pack-layout-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect) + (declare (ignore item rect)) (gfw:pack *layout-tester-win*)) (defclass layout-tester-widget-events (gfw:event-dispatcher) @@ -71,8 +71,8 @@ :initarg :id :initform 0))) -(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) @@ -139,8 +139,8 @@ :dispatcher be)))) (incf *widget-counter*))) -(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect) + (declare (ignore rect)) (setf (gfw:text btn) (funcall (toggle-fn d))) (gfw:layout *layout-tester-win*)) @@ -154,8 +154,8 @@ :initarg :subtype :initform :push-button))) -(defmethod gfw:event-select ((d add-child-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d add-child-dispatcher) item rect) + (declare (ignorable item rect)) (add-layout-tester-widget (widget-class d) (subtype d)) (gfw:pack *layout-tester-win*)) @@ -169,8 +169,8 @@ :initarg :sub-disp-class :initform nil))) -(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) - (declare (ignore time)) +(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type) + (declare (ignore type)) (gfw:clear-all menu) (gfw:mapchildren *layout-tester-win* (lambda (parent child) @@ -192,8 +192,8 @@ (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d remove-child-dispatcher) item rect) + (declare (ignore rect)) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) @@ -201,21 +201,21 @@ (defclass visibility-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect) + (declare (ignore rect)) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defun check-flow-orient-items (disp menu time) - (declare (ignore disp time)) +(defun check-flow-orient-items (disp menu type) + (declare (ignore disp type)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) -(defun set-flow-horizontal (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-horizontal (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) @@ -223,8 +223,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-vertical (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-vertical (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) @@ -232,8 +232,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-normalize (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-layout-normalize (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :normalize style) @@ -241,8 +241,8 @@ (setf (gfw:style-of layout) (push :normalize style))) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-wrap (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-layout-wrap (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) @@ -250,13 +250,13 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) -(defun enable-flow-spacing-items (disp menu time) - (declare (ignore disp time)) +(defun enable-flow-spacing-items (disp menu type) + (declare (ignore disp type)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) -(defun decrease-flow-spacing (disp item time rect) - (declare (ignore disp item time rect)) +(defun decrease-flow-spacing (disp item rect) + (declare (ignore disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (spacing (gfw:spacing-of layout))) (unless (zerop spacing) @@ -264,82 +264,82 @@ (setf (gfw:spacing-of layout) spacing) (gfw:layout *layout-tester-win*)))) -(defun increase-flow-spacing (disp item time rect) - (declare (ignore disp item time rect)) +(defun increase-flow-spacing (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*))) -(defun enable-left-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-left-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) -(defun enable-top-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-top-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) -(defun enable-right-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-right-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) -(defun enable-bottom-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-bottom-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) -(defun inc-left-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-left-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-top-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-top-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-right-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-right-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-bottom-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-bottom-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-left-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-left-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-top-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-top-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-right-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-right-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-bottom-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-bottom-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun flow-mod-callback (disp menu time) - (declare (ignore disp time)) +(defun flow-mod-callback (disp menu type) + (declare (ignore disp type)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenu ((:item "Left" @@ -383,8 +383,8 @@ (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) -(defun exit-layout-callback (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-layout-callback (disp item rect) + (declare (ignorable disp item rect)) (exit-layout-tester)) (defun run-layout-tester-internal () Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 9 02:35:37 2006 @@ -37,38 +37,37 @@ (defclass main-win-events (gfw:event-dispatcher) ()) -(defun windlg-exit-fn (disp item time rect) - (declare (ignore disp item time rect)) +(defun windlg-exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0)) -(defmethod gfw:event-close ((self main-win-events) window time) - (declare (ignore window time)) - (windlg-exit-fn self nil nil 0)) +(defmethod gfw:event-close ((self main-win-events) window) + (declare (ignore window)) + (windlg-exit-fn self nil nil)) (defclass test-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-paint ((d test-win-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((d test-win-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defclass test-mini-events (test-win-events) ()) -(defmethod gfw:event-close ((d test-mini-events) window time) - (declare (ignore time)) +(defmethod gfw:event-close ((d test-mini-events) window) (gfs:dispose window)) (defclass test-borderless-events (test-win-events) ()) -(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) - (declare (ignore time point button)) +(defmethod gfw:event-mouse-down ((d test-borderless-events) window point button) + (declare (ignore point button)) (gfs:dispose window)) -(defun create-borderless-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-borderless-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:borderless)))) @@ -76,8 +75,8 @@ (gfw:center-on-owner window) (gfw:show window t))) -(defun create-miniframe-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-miniframe-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Mini Frame" @@ -86,8 +85,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun create-palette-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-palette-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Palette" @@ -96,8 +95,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun open-file-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-file-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*main-win* '(:open :add-to-recent :multiple-select) paths @@ -108,8 +107,8 @@ :text "Select Lisp-related files...") (print paths))) -(defun save-file-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun save-file-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*main-win* '(:save) paths @@ -118,8 +117,8 @@ :initial-directory #P"c:/") (print paths))) -(defun choose-font-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun choose-font-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-graphics-context (gc *main-win*) (gfw:with-font-dialog (*main-win* nil font color :gc gc) (if color @@ -129,9 +128,7 @@ (defclass dialog-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) - (format t "dialog-events event-close called~%") +(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg)) @@ -140,16 +137,13 @@ (defun truncate-text (str) (subseq str 0 (min (length str) 5))) -(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit)) (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl)))) -(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit)) (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl)))) -(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit)) (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl)))) (defun open-dlg (title style) @@ -204,15 +198,15 @@ :style '(:vertical :normalize)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Cancel" @@ -226,12 +220,12 @@ (gfw:show dlg t) dlg)) -(defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-modal-dlg (disp item rect) + (declare (ignore disp item rect)) (open-dlg "Modal" '(:owner-modal))) -(defun open-modeless-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-modeless-dlg (disp item rect) + (declare (ignore disp item rect)) (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 9 02:35:37 2006 @@ -889,6 +889,10 @@ (defconstant +user-timer-maximum+ #x7FFFFFFF) (defconstant +user-timer-minimum+ #x0000000A) +(defconstant +wa-inactive+ 0) +(defconstant +wa-active+ 1) +(defconstant +wa-clickactive+ 2) + (defconstant +wb-left+ 0) (defconstant +wb-right+ 1) (defconstant +wb-isdelimiter+ 2) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 02:35:37 2006 @@ -33,162 +33,157 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric event-activate (dispatcher widget time) +(defgeneric event-activate (dispatcher widget type) (:documentation "Implement this to respond to an object being activated.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget type) + (declare (ignorable dispatcher widget type)))) -(defgeneric event-arm (dispatcher item time) +(defgeneric event-arm (dispatcher item) (:documentation "Implement this to respond to an object about to be selected.") - (:method (dispatcher item time) - (declare (ignorable dispatcher item time)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) -(defgeneric event-close (dispatcher widget time) +(defgeneric event-close (dispatcher widget) (:documentation "Implement this to respond to an object being closed.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-collapse (dispatcher item time rect) +(defgeneric event-collapse (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being collapsed.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect)))) -(defgeneric event-deactivate (dispatcher widget time) +(defgeneric event-deactivate (dispatcher widget type) (:documentation "Implement this to respond to an object being deactivated.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget type) + (declare (ignorable dispatcher widget type)))) -(defgeneric event-deiconify (dispatcher widget time) +(defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-dispose (dispatcher widget time) +(defgeneric event-dispose (dispatcher widget) (:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-expand (dispatcher item time rect) +(defgeneric event-expand (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being expanded.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect)))) -(defgeneric event-focus-gain (dispatcher widget time) +(defgeneric event-focus-gain (dispatcher widget) (:documentation "Implement this to respond to an object gaining keyboard focus.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-focus-loss (dispatcher widget time) +(defgeneric event-focus-loss (dispatcher widget) (:documentation "Implement this to respond to an object losing keyboard focus.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-hide (dispatcher widget time) +(defgeneric event-hide (dispatcher widget) (:documentation "Implement this to respond to an object being hidden.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-iconify (dispatcher widget time) +(defgeneric event-iconify (dispatcher widget) (:documentation "Implement this to respond to an object being iconified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-key-down (dispatcher widget time keycode char) +(defgeneric event-key-down (dispatcher widget keycode char) (:documentation "Implement this to respond to a key down event.") - (:method (dispatcher widget time keycode char) - (declare (ignorable dispatcher widget time keycode char)))) + (:method (dispatcher widget keycode char) + (declare (ignorable dispatcher widget keycode char)))) -(defgeneric event-key-traverse (dispatcher widget time keycode char type) - (:documentation "Implement this to respond to a key traversal event.") - (:method (dispatcher widget time keycode char type) - (declare (ignorable dispatcher widget time keycode char type)))) - -(defgeneric event-key-up (dispatcher widget time keycode char) +(defgeneric event-key-up (dispatcher widget keycode char) (:documentation "Implement this to respond to a key up event.") - (:method (dispatcher widget time keycode char) - (declare (ignorable dispatcher widget time keycode char)))) + (:method (dispatcher widget keycode char) + (declare (ignorable dispatcher widget keycode char)))) -(defgeneric event-modify (dispatcher widget time) +(defgeneric event-modify (dispatcher widget) (:documentation "Implement this to respond to content (e.g., text) in an object being modified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-mouse-double (dispatcher widget time point button) +(defgeneric event-mouse-double (dispatcher widget point button) (:documentation "Implement this to respond to a mouse double-click.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-down (dispatcher widget time point button) +(defgeneric event-mouse-down (dispatcher widget point button) (:documentation "Implement this to respond to a mouse down event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-enter (dispatcher widget time point button) +(defgeneric event-mouse-enter (dispatcher widget point button) (:documentation "Implement this to respond to a mouse passing into the bounds of an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-exit (dispatcher widget time point button) +(defgeneric event-mouse-exit (dispatcher widget point button) (:documentation "Implement this to respond to a mouse leaving the bounds an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-hover (dispatcher widget time point button) +(defgeneric event-mouse-hover (dispatcher widget point button) (:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-move (dispatcher widget time point button) +(defgeneric event-mouse-move (dispatcher widget point button) (:documentation "Implement this to respond to a mouse move event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-mouse-up (dispatcher widget time point button) +(defgeneric event-mouse-up (dispatcher widget point button) (:documentation "Implement this to respond to a mouse up event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button)))) -(defgeneric event-move (dispatcher widget time point) +(defgeneric event-move (dispatcher widget point) (:documentation "Implement this to respond to an object being moved within its parent's coordinate system.") - (:method (dispatcher widget time point) - (declare (ignorable dispatcher widget time point)))) + (:method (dispatcher widget point) + (declare (ignorable dispatcher widget point)))) -(defgeneric event-paint (dispatcher widget time gc rect) +(defgeneric event-paint (dispatcher widget gc rect) (:documentation "Implement this to respond to paint requests.") - (:method (dispatcher widget time gc rect) - (declare (ignorable dispatcher widget time gc rect)))) + (:method (dispatcher widget gc rect) + (declare (ignorable dispatcher widget gc rect)))) -(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content) +(defgeneric event-pre-modify (dispatcher widget keycode char span new-content) (:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.") - (:method (dispatcher widget time keycode char span new-content) - (declare (ignorable dispatcher widget time keycode char span new-content)))) + (:method (dispatcher widget keycode char span new-content) + (declare (ignorable dispatcher widget keycode char span new-content)))) -(defgeneric event-pre-move (dispatcher widget time) +(defgeneric event-pre-move (dispatcher widget) (:documentation "Implement this to preempt moving; return T if processed or nil if not.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-pre-resize (dispatcher widget time) +(defgeneric event-pre-resize (dispatcher widget) (:documentation "Implement this to preempt resizing; return T if processed or nil if not.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-resize (dispatcher widget time size type) +(defgeneric event-resize (dispatcher widget size type) (:documentation "Implement this to respond to an object being resized.") - (:method (dispatcher widget time size type) - (declare (ignorable dispatcher widget time size type)))) + (:method (dispatcher widget size type) + (declare (ignorable dispatcher widget size type)))) -(defgeneric event-select (dispatcher item time rect) +(defgeneric event-select (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being selected.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect)))) -(defgeneric event-show (dispatcher widget time) +(defgeneric event-show (dispatcher widget) (:documentation "Implement this to respond to an object being shown.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) -(defgeneric event-timer (dispatcher timer time) +(defgeneric event-timer (dispatcher timer) (:documentation "Implement this to respond to a tick from a specific timer.") - (:method (dispatcher timer time) - (declare (ignorable dispatcher timer time)))) + (:method (dispatcher timer) + (declare (ignorable dispatcher timer)))) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 02:35:37 2006 @@ -33,9 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) - (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:event-source integer gfs:rectangle)))) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-select . (gfw:event-source gfs:rectangle)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 02:35:37 2006 @@ -102,7 +102,7 @@ (when w (setf (gfs:point-x pnt) (lo-word lparam)) (setf (gfs:point-y pnt) (hi-word lparam)) - (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol))) + (funcall fn (dispatcher w) w pnt btn-symbol))) 0) (defun get-class-wndproc (hwnd) @@ -118,17 +118,15 @@ (error 'gfs:win32-error :detail "set-window-long failed"))) (defun dispatch-notification (widget wparam-hi) - (let ((disp (dispatcher widget)) - (time (event-time (thread-context)))) + (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug - (#.gfs::+en-killfocus+ (event-focus-loss disp widget time)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) - (#.gfs::+en-update+ (event-modify disp widget time))))) + (0 (event-select disp widget (gfs:make-rectangle))) ; FIXME + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget))))) (defun process-ctlcolor-message (wparam lparam) - (let* ((tc (thread-context)) - (widget (get-widget tc (cffi:make-pointer lparam))) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) (hdc (cffi:make-pointer wparam)) (bkgdcolor (brush-color-of widget)) (textcolor (text-color-of widget)) @@ -141,6 +139,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +(defun obtain-event-time () + (event-time (thread-context))) + ;;; ;;; process-message methods ;;; @@ -153,10 +154,9 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (w (get-widget tc hwnd))) + (let ((w (get-widget (thread-context) hwnd))) (if w - (event-close (dispatcher w) w (event-time tc)) + (event-close (dispatcher w) w) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -172,10 +172,7 @@ (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) - (event-select (dispatcher item) - item - (event-time tc) - (gfs:make-rectangle)))))) ; FIXME + (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t @@ -193,7 +190,7 @@ (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d menu (event-time tc)))))) + (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) @@ -203,7 +200,7 @@ (unless (null item) (let ((d (dispatcher item))) (unless (null d) - (event-arm d item (event-time tc)))))) + (event-arm d item))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) @@ -223,7 +220,7 @@ (w (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) (when w - (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch))) + (event-key-down (dispatcher w) w (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) @@ -234,7 +231,7 @@ (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) (when (and w (zerop ch)) - (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) + (event-key-down (dispatcher w) w wparam-lo (code-char ch)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) @@ -244,7 +241,7 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (when w - (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) + (event-key-up (dispatcher w) w wparam-lo (code-char ch)))) (setf (virtual-key tc) 0)) 0) @@ -289,14 +286,14 @@ (w (get-widget tc hwnd))) (when w (outer-location w (move-event-pnt tc)) - (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc)))) + (event-move (dispatcher w) w (move-event-pnt tc)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) - (if (and w (event-pre-move (dispatcher w) w (event-time tc))) + (if (and w (event-pre-move (dispatcher w) w)) 1 0))) @@ -318,7 +315,7 @@ :height gfs::rcpaint-height)) (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) (unwind-protect - (event-paint (dispatcher widget) widget (event-time tc) gc rct) + (event-paint (dispatcher widget) widget gc rct) (gfs:dispose gc) (gfs::end-paint hwnd ps-ptr)))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) @@ -357,7 +354,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (event-focus-loss (dispatcher widget) widget (event-time tc)))) + (event-focus-loss (dispatcher widget) widget))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) @@ -365,7 +362,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (event-focus-gain (dispatcher widget) widget (event-time tc)))) + (event-focus-gain (dispatcher widget) widget))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) @@ -407,15 +404,14 @@ (t nil)))) (when w (outer-size w (size-event-size tc)) - #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd) - (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type))) + (event-resize (dispatcher w) w (size-event-size tc) type))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) - (if (and w (event-pre-resize (dispatcher w) w (event-time tc))) + (if (and w (event-pre-resize (dispatcher w) w)) 1 0))) @@ -427,15 +423,15 @@ (gfs::kill-timer hwnd wparam) (cond ((<= (delay-of timer) 0) - (event-timer (dispatcher timer) timer (event-time tc)) + (event-timer (dispatcher timer) timer) (gfs:dispose timer)) ((/= (delay-of timer) (initial-delay-of timer)) (let ((delay (reset-timer-to-delay timer (delay-of timer)))) (setf (slot-value timer 'delay) delay) (setf (slot-value timer 'initial-delay) delay)) - (event-timer (dispatcher timer) timer (event-time tc))) + (event-timer (dispatcher timer) timer)) (t - (event-timer (dispatcher timer) timer (event-time tc)))))) + (event-timer (dispatcher timer) timer))))) 0) ;;; Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 9 02:35:37 2006 @@ -153,7 +153,7 @@ (defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) - (event-dispose (dispatcher w) w (event-time (thread-context)))) + (event-dispose (dispatcher w) w)) (let ((hwnd (gfs:handle w))) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 9 02:35:37 2006 @@ -180,8 +180,8 @@ (let ((sz (client-size win))) (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (win window) time size type) - (declare (ignorable d time size type)) +(defmethod event-resize ((d event-dispatcher) (win window) size type) + (declare (ignore size type)) (unless (null (layout-of win)) (let ((sz (client-size win))) (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))

1 0

[graphic-forms-cvs] r185 - in trunk: . src/demos/textedit
by junrue＠common-lisp.net 08 Jul '06

08 Jul '06

Author: junrue Date: Sat Jul 8 15:43:21 2006 New Revision: 185 Modified: trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-document.lisp trunk/src/demos/textedit/textedit-window.lisp Log: implemented basic text file I/O Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Jul 8 15:43:21 2006 @@ -60,6 +60,7 @@ ((:module "demos" :components ((:module "textedit" + :serial t :components ((:file "textedit-document") (:file "textedit-window"))) Modified: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-document.lisp (original) +++ trunk/src/demos/textedit/textedit-document.lisp Sat Jul 8 15:43:21 2006 @@ -41,4 +41,24 @@ (content-modified :cell :ephemeral :accessor content-modified + :initform (cells:c-in nil)) + (file-path + :accessor file-path :initform (cells:c-in nil)))) + +(defvar *textedit-model* (make-instance 'textedit-document)) + +(defun load-textedit-doc (path) + (let ((buffer "")) + (with-open-file (input path) + (do ((line (read-line input nil) + (read-line input nil))) + ((null line)) + (if (zerop (length line)) + (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline))) + (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline)))))) + (setf (content-replaced *textedit-model*) buffer))) + +(defun save-textedit-doc (path buffer) + (with-open-file (output path :direction :output :if-exists :supersede) + (format output buffer))) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sat Jul 8 15:43:21 2006 @@ -33,41 +33,53 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *textedit-control* nil) -(defvar *textedit-win* nil) -(defvar *textedit-startup-dir* nil) +(defvar *textedit-control* nil) +(defvar *textedit-win* nil) +(defvar *textedit-startup-dir* nil) + +(defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") + ("All Files (*.*)" . "*.*"))) (defun manage-textedit-file-menu (disp menu time) (declare (ignore disp time)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) -(defun new-textedit-doc (disp item time rect) +(defun textedit-file-new (disp item time rect) (declare (ignore disp item time rect)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") - (setf (gfw:text-modified-p *textedit-control*) nil))) + (setf (gfw:text-modified-p *textedit-control*) nil) + (setf (file-path *textedit-model*) nil))) -(defun open-textedit-doc (disp item time rect) +(defun textedit-file-open (disp item time rect) (declare (ignore disp item time rect)) (gfw:with-file-dialog (*textedit-win* '(:open :add-to-recent :path-must-exist) paths - :filters '(("Text Files (*.txt)" . "*.txt") - ("All Files (*.*)" . "*.*"))))) - -(defun save-textedit-doc (disp item time rect) - (declare (ignore disp item time rect))) + :filters *textedit-file-filters*) + (when paths + (load-textedit-doc (first paths)) + (setf (file-path *textedit-model*) (namestring (first paths)))))) + +(defun textedit-file-save (disp item time rect) + (if (file-path *textedit-model*) + (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) + (textedit-file-save-as disp item time rect)) + (setf (gfw:text-modified-p *textedit-control*) nil)) -(defun save-as-textedit-doc (disp item time rect) +(defun textedit-file-save-as (disp item time rect) (declare (ignore disp item time rect)) (gfw:with-file-dialog (*textedit-win* '(:save :add-to-recent) paths - :filters '(("Text Files (*.txt)" . "*.txt") - ("All Files (*.*)" . "*.*")) - :text "Save As"))) + :filters *textedit-file-filters* + :text "Save As") + (when paths + (save-textedit-doc (first paths) (gfw:text *textedit-control*)) + (setf (file-path *textedit-model*) (namestring (first paths))) + (setf (gfw:text-modified-p *textedit-control*) nil)))) -(defun quit-textedit (disp item time rect) +(defun textedit-file-quit (disp item time rect) (declare (ignore disp item time rect)) (setf *textedit-control* nil) (gfs:dispose *textedit-win*) @@ -85,7 +97,7 @@ (defmethod gfw:event-close ((disp textedit-win-events) window time) (declare (ignore window time)) - (quit-textedit disp nil nil nil)) + (textedit-file-quit disp nil nil nil)) (defmethod gfw:event-focus-gain ((self textedit-win-events) window time) (declare (ignore window time)) @@ -162,18 +174,23 @@ (cells:defobserver content-modified ((self textedit-document))) +(cells:defobserver file-path ((self textedit-document)) + (if *textedit-win* + (setf (gfw:text *textedit-win*) (format nil "~s - GraphicForms TextEdit" (file-path self))) + (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) + (defun textedit-startup () #+clisp (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu - :submenu ((:item "&New" :callback #'new-textedit-doc) - (:item "&Open..." :callback #'open-textedit-doc) - (:item "&Save" :callback #'save-textedit-doc :disabled) - (:item "Save &As..." :callback #'save-as-textedit-doc) + :submenu ((:item "&New" :callback #'textedit-file-new) + (:item "&Open..." :callback #'textedit-file-open) + (:item "&Save" :callback #'textedit-file-save :disabled) + (:item "Save &As..." :callback #'textedit-file-save-as) (:item "" :separator) - (:item "E&xit" :callback #'quit-textedit))) + (:item "E&xit" :callback #'textedit-file-quit))) (:item "&Edit" :submenu ((:item "&Undo") (:item "" :separator) @@ -202,6 +219,7 @@ :want-return))) (setf (gfw:menu-bar *textedit-win*) menubar) (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) + (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit") (gfw:show *textedit-win* t))) (defun textedit ()

1 0

[graphic-forms-cvs] r184 - in trunk: . docs/manual src src/demos/textedit src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Jul '06

07 Jul '06

Author: junrue Date: Fri Jul 7 18:37:45 2006 New Revision: 184 Added: trunk/src/demos/textedit/textedit-document.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: defined text-modified-p generic function and implemented it for edit controls; added initial model definition for textedit demo Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Jul 7 18:37:45 2006 @@ -1316,6 +1316,15 @@ the custom control will be managed by a @ref{layout-manager}. @end deffn +@anchor{text-modified-p} +@deffn GenericFunction text-modified-p self +Returns T if the text component of @code{self} has been modified by +the user; @sc{nil} otherwise. The corresponding @sc{setf} function +updates the dirty state flag. This function is not implemented for all +widgets, since in some cases there are multiple text components and in +other cases there is no text component at all. +@end deffn + @deffn GenericFunction update self Forces all outstanding paint requests for the object to be processed before this function returns. Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Jul 7 18:37:45 2006 @@ -61,7 +61,8 @@ :components ((:module "textedit" :components - ((:file "textedit-window"))) + ((:file "textedit-document") + (:file "textedit-window"))) (:module "unblocked" :components ((:file "tiles") Added: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/textedit/textedit-document.lisp Fri Jul 7 18:37:45 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; textedit-document.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(cells:defmodel textedit-document () + ((content-replaced + :cell :ephemeral + :accessor content-replaced + :initform (cells:c-in nil)) + (content-modified + :cell :ephemeral + :accessor content-modified + :initform (cells:c-in nil)))) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Fri Jul 7 18:37:45 2006 @@ -37,10 +37,35 @@ (defvar *textedit-win* nil) (defvar *textedit-startup-dir* nil) +(defun manage-textedit-file-menu (disp menu time) + (declare (ignore disp time)) + (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) + (defun new-textedit-doc (disp item time rect) (declare (ignore disp item time rect)) - (if *textedit-control* - (setf (gfw:text *textedit-control*) ""))) + (when *textedit-control* + (setf (gfw:text *textedit-control*) "") + (setf (gfw:text-modified-p *textedit-control*) nil))) + +(defun open-textedit-doc (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:with-file-dialog (*textedit-win* + '(:open :add-to-recent :path-must-exist) + paths + :filters '(("Text Files (*.txt)" . "*.txt") + ("All Files (*.*)" . "*.*"))))) + +(defun save-textedit-doc (disp item time rect) + (declare (ignore disp item time rect))) + +(defun save-as-textedit-doc (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:with-file-dialog (*textedit-win* + '(:save :add-to-recent) + paths + :filters '(("Text Files (*.txt)" . "*.txt") + ("All Files (*.*)" . "*.*")) + :text "Save As"))) (defun quit-textedit (disp item time rect) (declare (ignore disp item time rect)) @@ -131,16 +156,22 @@ (gfw:center-on-owner dlg) (gfw:show dlg t))) +(cells:defobserver content-replaced ((self textedit-document)) + (if *textedit-control* + (setf (gfw:text *textedit-control*) (content-replaced self)))) + +(cells:defobserver content-modified ((self textedit-document))) + (defun textedit-startup () #+clisp (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) - (let ((menubar (gfw:defmenu ((:item "&File" + (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'new-textedit-doc) - (:item "&Open...") - (:item "&Save") - (:item "Save &As...") + (:item "&Open..." :callback #'open-textedit-doc) + (:item "&Save" :callback #'save-textedit-doc :disabled) + (:item "Save &As..." :callback #'save-as-textedit-doc) (:item "" :separator) (:item "E&xit" :callback #'quit-textedit))) (:item "&Edit" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Jul 7 18:37:45 2006 @@ -486,6 +486,7 @@ #:text-baseline #:text-height #:text-limit + #:text-modified-p #:thumb-size #:tooltip-text #:top-child-of Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Jul 7 18:37:45 2006 @@ -126,3 +126,9 @@ (defmethod text-baseline ((self edit)) (widget-text-baseline self +vertical-edit-text-margin+)) + +(defmethod text-modified-p ((self edit)) + (/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0)) + +(defmethod (setf text-modified-p) (flag (self edit)) + (gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 0) 0)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Jul 7 18:37:45 2006 @@ -357,6 +357,9 @@ (defgeneric text-limit (self) (:documentation "Returns the number of characters that the object's text field is capable of holding.")) +(defgeneric text-modified-p (self) + (:documentation "Returns true if the text component has been modified; nil otherwise.")) + (defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Jul 7 18:37:45 2006 @@ -319,18 +319,27 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod (setf text-modified-p) :before (flag (self widget)) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod text-modified-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod update :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) -(defmethod update ((w widget)) - (let ((hwnd (gfs:handle w))) +(defmethod update ((self widget)) + (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd)))) -(defmethod visible-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod visible-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod visible-p ((w widget)) - (not (zerop (gfs::is-window-visible (gfs:handle w))))) +(defmethod visible-p ((self widget)) + (not (zerop (gfs::is-window-visible (gfs:handle self)))))

1 0

[graphic-forms-cvs] r183 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Jul '06

07 Jul '06

Author: junrue Date: Fri Jul 7 15:16:26 2006 New Revision: 183 Modified: trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp Log: refactored ctlcolor message handling, implemented better means for setting control fonts Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Jul 7 15:16:26 2006 @@ -117,7 +117,13 @@ (defmethod (setf gfg:font) (font (self control)) (setf (font-of self) font) + (gfs::send-message (gfs:handle self) + gfs::+wm-setfont+ + (cffi:pointer-address (gfs:handle font)) + 1)) +#| (redraw self)) +|# (defmethod gfg:foreground-color :before ((self control)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Jul 7 15:16:26 2006 @@ -126,6 +126,21 @@ (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) (#.gfs::+en-update+ (event-modify disp widget time))))) +(defun process-ctlcolor-message (wparam lparam) + (let* ((tc (thread-context)) + (widget (get-widget tc (cffi:make-pointer lparam))) + (hdc (cffi:make-pointer wparam)) + (bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget)) + (ret-val 0)) + (when widget + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) + ret-val)) + ;;; ;;; process-message methods ;;; @@ -309,33 +324,21 @@ (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) +(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam) + (declare (ignore hwnd)) + (process-ctlcolor-message wparam lparam)) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam) + (declare (ignore hwnd)) + (process-ctlcolor-message wparam lparam)) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam) + (declare (ignore hwnd)) + (process-ctlcolor-message wparam lparam)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) (declare (ignore hwnd)) - (let* ((tc (thread-context)) - (widget (get-widget tc (cffi:make-pointer lparam))) - (hdc (cffi:make-pointer wparam)) - (bkgdcolor (brush-color-of widget)) - (textcolor (text-color-of widget)) - (ret-val 0)) - (when widget -#| - ;; temporarily disabling this until I decide whether this sort - ;; of sanity check really makes sense (for one thing, I didn't - ;; expect buttons with BS_CHECKBOX or BS_RADIOBUTTON to send - ;; WM_CTLCOLORSTATIC, but I guess it makes sense). - ;; - (if (not (or (typep widget 'button) (typep widget 'label))) - (warn 'gfs:toolkit-warning :detail "incorrect widget type received WM_CTLCOLORSTATIC")) -|# - (let ((font (font-of widget))) - (if font - (gfs::select-object hdc (gfs:handle font)))) - (if bkgdcolor - (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) - (if textcolor - (gfs::set-text-color hdc (gfg:color->rgb textcolor))) - (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) - ret-val)) + (process-ctlcolor-message wparam lparam)) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam))

1 0

[graphic-forms-cvs] r182 - in trunk: docs/manual src src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Jul '06

07 Jul '06

Author: junrue Date: Fri Jul 7 13:52:59 2006 New Revision: 182 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: created with-graphics-context macro to simplify common usage Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Jul 7 13:52:59 2006 @@ -1356,6 +1356,14 @@ keyword. @xref{font-dialog}. @end deffn +@anchor{with-graphics-context} +@deffn Macro with-graphics-context (gc &optional thing) &body body +This macro manages a @ref{graphics-context} representing the underlying +device context of @code{thing}, which can be a @ref{widget} or an +@ref{image}. If @code{thing} is not specified, then the macro creates +a graphics-context compatible with the @ref{display}. +@end deffn + @node layout functions @section layout functions Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Fri Jul 7 13:52:59 2006 @@ -49,6 +49,13 @@ (setf *textedit-win* nil) (gfw:shutdown 0)) +(defun textedit-font (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:with-graphics-context (gc *textedit-control*) + (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) + (if font + (setf (gfg:font *textedit-control*) font))))) + (defclass textedit-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-win-events) window time) @@ -151,7 +158,7 @@ (:item "" :separator) (:item "Select &All"))) (:item "F&ormat" - :submenu ((:item "&Font..."))) + :submenu ((:item "&Font..." :callback #'textedit-font))) (:item "&Help" :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Jul 7 13:52:59 2006 @@ -64,13 +64,11 @@ :initform nil))) (defun draw-tiles-directly (panel shape-pnts kind) - (let ((gc (make-instance 'gfg:graphics-context :widget panel)) - (image-table (tile-image-table-of (gfw:dispatcher panel)))) - (unwind-protect - (loop for pnt in shape-pnts - do (let ((image (gethash kind image-table))) - (gfg:draw-image gc image (tiles->window pnt)))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc panel) + (let ((image-table (tile-image-table-of (gfw:dispatcher panel)))) + (loop for pnt in shape-pnts + do (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt))))))) (defmethod dispose ((self tiles-panel-events)) (let ((table (tile-image-table-of self))) @@ -129,16 +127,13 @@ (setf (shape-pnts-of self) nil)) (defmethod update-buffer ((self tiles-panel-events)) - (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self))) - (unwind-protect - (progn - (clear-buffer self gc) - (map-tiles #'(lambda (pnt kind) - (unless (= kind 0) - (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc (image-buffer-of self)) + (let ((image-table (tile-image-table-of self))) + (clear-buffer self gc) + (map-tiles #'(lambda (pnt kind) + (unless (= kind 0) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) + (game-tiles))))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Jul 7 13:52:59 2006 @@ -500,6 +500,7 @@ #:visible-p #:with-file-dialog #:with-font-dialog + #:with-graphics-context ;; conditions )) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Jul 7 13:52:59 2006 @@ -120,14 +120,12 @@ (defun choose-font-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*))) - (unwind-protect - (gfw:with-font-dialog (*main-win* nil font color :gc gc) - (if color - (print color)) - (if font - (print (gfg:data-object font gc)))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc *main-win*) + (gfw:with-font-dialog (*main-win* nil font color :gc gc) + (if color + (print color)) + (if font + (print (gfg:data-object font gc)))))) (defclass dialog-events (gfw:event-dispatcher) ()) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Jul 7 13:52:59 2006 @@ -131,18 +131,15 @@ (let* ((color (gfg:background-color label)) (size (gfg:size image)) (bounds (gfs:make-rectangle :size size)) - (tmp-image (make-instance 'gfg:image :size size)) - (gc (make-instance 'gfg:graphics-context :image tmp-image))) - (unwind-protect - (progn - (setf (gfg:background-color gc) color) - (let ((orig-color (gfg:foreground-color gc))) - (setf (gfg:foreground-color gc) color) - (gfg:draw-filled-rectangle gc bounds) - (setf (gfg:foreground-color gc) orig-color)) - (gfg:draw-image gc image (gfs:location bounds)) - (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) - (gfs:dispose gc)) + (tmp-image (make-instance 'gfg:image :size size))) + (with-graphics-context (gc tmp-image) + (setf (gfg:background-color gc) color) + (let ((orig-color (gfg:foreground-color gc))) + (setf (gfg:foreground-color gc) color) + (gfg:draw-filled-rectangle gc bounds) + (setf (gfg:foreground-color gc) orig-color)) + (gfg:draw-image gc image (gfs:location bounds)) + (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Jul 7 13:52:59 2006 @@ -35,6 +35,22 @@ (defvar *check-box-size* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-graphics-context ((gc &optional thing) &body body) + `(let ((,gc (cond + ((null ,thing) + (make-instance 'gfg:graphics-context)) ; DC compatible with display + ((typep ,thing 'gfw:widget) + (make-instance 'gfg:graphics-context :widget ,thing)) + ((typep ,thing 'gfg:image) + (make-instance 'gfg:graphics-context :image ,thing)) + (t + (error 'gfs:toolkit-error + :detail (format nil "~a is an unsupported type" ,thing)))))) + (unwind-protect + (progn + ,@body) + (gfs:dispose ,gc))))) (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) @@ -187,17 +203,15 @@ (let ((size (gfw:size widget)) (b-width (border-width widget)) (font (gfg:font widget)) - (gc (make-instance 'gfg:graphics-context :widget widget)) (baseline 0)) - (unwind-protect - (let ((metrics (gfg:metrics gc font))) - (setf baseline (+ b-width - top-margin - (gfg:ascent metrics) - (floor (- (gfs:size-height size) - (+ (gfg:ascent metrics) (gfg:descent metrics))) - 2)))) - (gfs:dispose gc)) + (with-graphics-context (gc widget) + (let ((metrics (gfg:metrics gc font))) + (setf baseline (+ b-width + top-margin + (gfg:ascent metrics) + (floor (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2))))) baseline)) (defun check-box-size ()

1 0

[graphic-forms-cvs] r181 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Jul '06

07 Jul '06

Author: junrue Date: Fri Jul 7 02:35:23 2006 New Revision: 181 Modified: trunk/src/uitoolkit/widgets/edit.lisp Log: somehow missed a stray call to obsolete replace-edit-wordbreak-func Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Jul 7 02:35:23 2006 @@ -95,9 +95,7 @@ ex-style (increment-widget-id (thread-context))))) (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self) - (if (find :auto-hscroll (style-of self)) - (replace-edit-wordbreak-func self))) + (init-control self)) (defmethod line-count ((self edit)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r180 - in trunk/src: demos/textedit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 07 Jul '06

07 Jul '06

Author: junrue Date: Fri Jul 7 02:34:12 2006 New Revision: 180 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event.lisp Log: some minor cleanup after a bunch of experimentation trying to use EditWordBreakProc to implement dynamically changing word wrap behavior in edit controls, which I have given up on for now Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Fri Jul 7 02:34:12 2006 @@ -49,18 +49,6 @@ (setf *textedit-win* nil) (gfw:shutdown 0)) -(defun format-textedit (disp menu time) - (declare (ignore disp time)) - (gfw:check (elt (gfw:items menu) 1) - (and *textedit-control* (gfw:auto-hscroll-p *textedit-control*)))) - -(defun wordwrap-textedit (disp item time rect) - (declare (ignore disp item time rect)) - (when *textedit-control* - (let ((flag (not (gfw:auto-hscroll-p *textedit-control*)))) - ;(gfw:enable-auto-scrolling *textedit-control* flag t) - (gfw:enable-scrollbars *textedit-control* flag t)))) - (defclass textedit-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-win-events) window time) @@ -162,9 +150,8 @@ (:item "&Go To...") (:item "" :separator) (:item "Select &All"))) - (:item "F&ormat" :callback #'format-textedit - :submenu ((:item "&Font...") - (:item "&Word Wrap" :callback #'wordwrap-textedit))) + (:item "F&ormat" + :submenu ((:item "&Font..."))) (:item "&Help" :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) @@ -172,8 +159,7 @@ :style '(:frame))) (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win* :style '(:multi-line - :auto-hscroll :auto-vscroll - :horizontal-scrollbar + :auto-vscroll :vertical-scrollbar :want-return))) (setf (gfw:menu-bar *textedit-win*) menubar) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Jul 7 02:34:12 2006 @@ -889,6 +889,10 @@ (defconstant +user-timer-maximum+ #x7FFFFFFF) (defconstant +user-timer-minimum+ #x0000000A) +(defconstant +wb-left+ 0) +(defconstant +wb-right+ 1) +(defconstant +wb-isdelimiter+ 2) + (defconstant +wm-create+ #x0001) (defconstant +wm-destroy+ #x0002) (defconstant +wm-move+ #x0003) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Jul 7 02:34:12 2006 @@ -74,10 +74,6 @@ (setf std-flags (logior std-flags gfs::+es-autohscroll+))) (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) -(defmethod enable-auto-scrolling ((self edit) horizontal vertical) - (declare (ignore horizontal vertical)) - (error 'gfs:toolkit-error :detail "not yet implemented")) - (defmethod enable-scrollbars ((self edit) horizontal vertical) (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) (if horizontal @@ -99,7 +95,9 @@ ex-style (increment-widget-id (thread-context))))) (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self)) + (init-control self) + (if (find :auto-hscroll (style-of self)) + (replace-edit-wordbreak-func self))) (defmethod line-count ((self edit)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Jul 7 02:34:12 2006 @@ -114,8 +114,7 @@ (defun subclass-wndproc (hwnd) (if (zerop (gfs::set-window-long hwnd gfs::+gwlp-wndproc+ - (cffi:pointer-address - (cffi:get-callback 'subclassing_wndproc)))) + (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) (defun dispatch-notification (widget wparam-hi)

1 0

[graphic-forms-cvs] r179 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets
by junrue＠common-lisp.net 06 Jul '06

06 Jul '06

Author: junrue Date: Thu Jul 6 12:19:37 2006 New Revision: 179 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/glossary.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: defined new generic functions for configuring auto-scrolling and scrollbars; refactored existing code that modifies native styles to use a centralized function to set the bits and then refresh the hwnd Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jul 6 12:19:37 2006 @@ -294,11 +294,14 @@ Specifies that the @code{edit control} will scroll text content to the right by 10 characters when the user types a character at the end of the line. For single-line @code{edit control}s, this style is set -by the library. +by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and +@ref{enable-auto-scrolling}. @item :auto-vscroll Specifies that the @code{edit control} will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword -is only meaningful when @code{:multi-line} is also specified. +is only meaningful when @code{:multi-line} is also specified. See +@ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and +@ref{enable-auto-scrolling}. @item :horizontal-scrollbar Specifies that a horizontal scrollbar should be displayed. @item :mask-characters @@ -964,6 +967,18 @@ be used to set the menu item's initial state. @end deffn +@anchor{auto-hscroll-p} +@deffn GenericFunction auto-hscroll-p self => boolean +Returns T if @code{self} is configured for automatic horizontal scrolling; +@sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}. +@end deffn + +@anchor{auto-vscroll-p} +@deffn GenericFunction auto-vscroll-p self => boolean +Returns T if @code{self} is configured for automatic vertical scrolling; +@sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}. +@end deffn + @deffn GenericFunction cancel-widget self Returns the @ref{widget} that responds to the @sc{esc} key or otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this @@ -1055,6 +1070,13 @@ function is also used to start and stop @ref{timer}s. @end deffn +@anchor{enable-auto-scrolling} +@deffn GenericFunction enable-auto-scrolling self horizontal vertical +Configures the object to allow (or to disable) automatic scrolling in +the horizontal or vertical directions. See @ref{auto-hscroll-p} +and @ref{auto-vscroll-p}. +@end deffn + @deffn GenericFunction enable-layout self flag Cause the object to allow or disallow layout management. @end deffn @@ -1063,6 +1085,16 @@ Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. @end deffn +@anchor{enable-scrollbars} +@deffn GenericFunction enable-scrollbars self horizontal vertical +Specifying T for @code{horizontal} (@code{vertical}) reveals a +scrollbar to attached to the right-hand (bottom) of +@code{self}. Specifying @sc{nil} hides the scrollbar. These flags do +not affect scrolling behavior in @code{self} -- they only control +scrollbar visibility. See @ref{horizontal-scrollbar-p} and +@ref{vertical-scrollbar-p}. +@end deffn + @anchor{file-dialog-paths} @deffn Function file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @@ -1094,6 +1126,12 @@ Places keyboard focus on @code{self}. @end deffn +@anchor{horizontal-scrollbar-p} +@deffn GenericFunction horizontal-scrollbar-p self => boolean +Returns T if @code{self} has been configured to display a horizontal +scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +@end deffn + @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn @@ -1283,6 +1321,12 @@ before this function returns. @end deffn +@anchor{vertical-scrollbar-p} +@deffn GenericFunction vertical-scrollbar-p self => boolean +Returns T if @code{self} has been configured to display a vertical +scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +@end deffn + @deffn GenericFunction visible-p self Returns T if the object is visible (not necessarily top-most); nil otherwise. @end deffn Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Thu Jul 6 12:19:37 2006 @@ -26,6 +26,13 @@ intended for more knowledgeable users and should not be the sole mechanism for invoking functionality. Compare with @ref{mnemonic}. +@item auto-scrolling +@cindex auto-scrolling +Auto-scrolling is a feature whereby scrolling occurs +as a side effect of user input so content can remain visible, +thus avoiding the need to explicitly manipulate scrollbars to +achieve the same result. + @item control @cindex control A control is a system-defined window class that accepts user input Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Jul 6 12:19:37 2006 @@ -49,6 +49,18 @@ (setf *textedit-win* nil) (gfw:shutdown 0)) +(defun format-textedit (disp menu time) + (declare (ignore disp time)) + (gfw:check (elt (gfw:items menu) 1) + (and *textedit-control* (gfw:auto-hscroll-p *textedit-control*)))) + +(defun wordwrap-textedit (disp item time rect) + (declare (ignore disp item time rect)) + (when *textedit-control* + (let ((flag (not (gfw:auto-hscroll-p *textedit-control*)))) + ;(gfw:enable-auto-scrolling *textedit-control* flag t) + (gfw:enable-scrollbars *textedit-control* flag t)))) + (defclass textedit-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-win-events) window time) @@ -150,9 +162,9 @@ (:item "&Go To...") (:item "" :separator) (:item "Select &All"))) - (:item "F&ormat" + (:item "F&ormat" :callback #'format-textedit :submenu ((:item "&Font...") - (:item "&Word Wrap"))) + (:item "&Word Wrap" :callback #'wordwrap-textedit))) (:item "&Help" :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Jul 6 12:19:37 2006 @@ -317,6 +317,8 @@ #:append-item #:append-separator #:append-submenu + #:auto-hscroll-p + #:auto-vscroll-p #:background-color #:background-pattern #:border-width @@ -355,8 +357,10 @@ #:display-to-object #:echo-char #:enable + #:enable-auto-scrolling #:enable-layout #:enable-redraw + #:enable-scrollbars #:enabled-p #:event-activate #:event-arm Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Jul 6 12:19:37 2006 @@ -40,6 +40,14 @@ ;;; methods ;;; +(defmethod auto-hscroll-p ((self edit)) + (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+))) + +(defmethod auto-vscroll-p ((self edit)) + (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) + (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) @@ -66,6 +74,20 @@ (setf std-flags (logior std-flags gfs::+es-autohscroll+))) (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) +(defmethod enable-auto-scrolling ((self edit) horizontal vertical) + (declare (ignore horizontal vertical)) + (error 'gfs:toolkit-error :detail "not yet implemented")) + +(defmethod enable-scrollbars ((self edit) horizontal vertical) + (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (if horizontal + (setf bits (logior bits gfs::+ws-hscroll+)) + (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) + (if vertical + (setf bits (logior bits gfs::+ws-vscroll+)) + (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) + (update-native-style self bits))) + (defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Jul 6 12:19:37 2006 @@ -63,11 +63,7 @@ (setf new-flags (logior orig-flags gfs::+ws-maximizebox+)) (setf new-flags (logior new-flags gfs::+ws-thickframe+)))) (when (/= orig-flags new-flags) - (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags) - (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ - gfs::+swp-nomove+ - gfs::+swp-nosize+ - gfs::+swp-nozorder+))))) + (update-native-style win new-flags)))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Jul 6 12:19:37 2006 @@ -54,6 +54,12 @@ (defgeneric append-submenu (self text submenu dispatcher &optional checked disabled) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) +(defgeneric auto-hscroll-p (self) + (:documentation "Returns T if automatic horizontal scrolling is enabled; nil otherwise.")) + +(defgeneric auto-vscroll-p (self) + (:documentation "Returns T if automatic vertical scrolling is enabled; nil otherwise.")) + (defgeneric border-width (self) (:documentation "Returns the object's border width.")) @@ -135,6 +141,9 @@ (defgeneric enable (self flag) (:documentation "Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected.")) +(defgeneric enable-auto-scrolling (self horizontal vertical) + (:documentation "Enables or disables automatic scrolling in either dimension.")) + (defgeneric enable-layout (self flag) (:documentation "Cause the object to allow or disallow layout management.")) @@ -144,6 +153,9 @@ (defgeneric enabled-p (self) (:documentation "Returns T if the object is enabled; nil otherwise.")) +(defgeneric enable-scrollbars (self horizontal vertical) + (:documentation "Shows or hides scrollbars for the widget in either dimension.")) + (defgeneric expand (self deep flag) (:documentation "Set the object (and optionally it's children) to the expanded or collapsed state.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Jul 6 12:19:37 2006 @@ -116,6 +116,14 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) +(defun update-native-style (widget bits) + (let ((hwnd (gfs:handle widget))) + (gfs::set-window-long hwnd gfs::+gwl-style+ bits) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+)))) + (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 6 12:19:37 2006 @@ -79,12 +79,20 @@ (error 'gfs:toolkit-error :detail "no widget for parent handle")) (ancestor-p ancestor parent))) -(defmethod border-width :before ((widget widget)) - (if (gfs:disposed-p widget) +(defmethod auto-hscroll-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod auto-vscroll-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod border-width :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod border-width ((widget widget)) - (let* ((hwnd (gfs:handle widget)) +(defmethod border-width ((self widget)) + (let* ((hwnd (gfs:handle self)) (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) (cond ((/= (logand bits gfs::+ws-ex-clientedge+) 0) @@ -152,13 +160,18 @@ (error 'gfs:win32-error :detail "destroy-window failed")))) (setf (slot-value w 'gfs:handle) nil)) -(defmethod enable :before ((w widget) flag) +(defmethod enable :before ((self widget) flag) (declare (ignore flag)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enable ((w widget) flag) - (gfs::enable-window (gfs:handle w) (if (null flag) 0 1))) +(defmethod enable ((self widget) flag) + (gfs::enable-window (gfs:handle self) (if (null flag) 0 1))) + +(defmethod enable-auto-scrolling :before ((self widget) hscroll vscroll) + (declare (ignore hscroll vscroll)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) (defmethod enabled-p :before ((w widget)) (if (gfs:disposed-p w)

1 0