mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 01 Oct '07

01 Oct '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv23798 Modified Files: medium.lisp Log Message: fix dumb mistake in COMPUTE-ARC-POINT where I handle the angle > 360 case --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/10/01 01:12:15 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/10/01 01:19:34 1.12 @@ -307,28 +307,28 @@ (multiple-value-bind (count remainder) (floor angle 360) (if (> count 0) - (compute-arc-point center-x center-y width height remainder) - (cond - ((= angle 270) - (gfs:make-point :x (floor center-x) - :y (+ (floor center-y) (floor height 2)))) - ((> angle 270) - (compute-quad-point center-x height (- angle 270))) - ((= angle 180) - (gfs:make-point :x (- (floor center-x) (floor width 2)) - :y (floor center-y))) - ((> angle 180) - (compute-quad-point center-x height (- angle 180))) - ((= angle 90) - (gfs:make-point :x (floor center-x) - :y (- (floor center-y) (floor height 2)))) - ((> angle 90) - (compute-quad-point center-x height(- angle 90))) - ((= angle 0) - (gfs:make-point :x (+ (floor center-x) (floor width 2)) - :y (floor center-y))) - (t - (compute-quad-point center-x height angle))))))) + (setf angle remainder))) + (cond + ((= angle 270) + (gfs:make-point :x (floor center-x) + :y (+ (floor center-y) (floor height 2)))) + ((> angle 270) + (compute-quad-point center-x height (- angle 270))) + ((= angle 180) + (gfs:make-point :x (- (floor center-x) (floor width 2)) + :y (floor center-y))) + ((> angle 180) + (compute-quad-point center-x height (- angle 180))) + ((= angle 90) + (gfs:make-point :x (floor center-x) + :y (- (floor center-y) (floor height 2)))) + ((> angle 90) + (compute-quad-point center-x height(- angle 90))) + ((= angle 0) + (gfs:make-point :x (+ (floor center-x) (floor width 2)) + :y (floor center-y))) + (t + (compute-quad-point center-x height angle))))) (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 01 Oct '07

01 Oct '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv23469 Modified Files: medium.lisp Log Message: oops, forgot to remove old ellipse code --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/10/01 01:10:35 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/10/01 01:12:15 1.11 @@ -366,44 +366,6 @@ (gfg:draw-arc gc rect start-pnt end-pnt))))) (add-medium-to-render medium))) -#| -;; FIXME: completely untested. Not sure we're even using the right GFG h -;; functions. Are start-point and end-point right? -(defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y - radius-1-dx radius-1-dy - radius-2-dx radius-2-dy - start-angle end-angle filled) - (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) - (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) - (when (target-of medium) - (gfw:with-graphics-context (gc (target-of medium)) - (let ((color (ink-to-color medium (medium-ink medium)))) - (if filled - (setf (gfg:background-color gc) color)) - (setf (gfg:foreground-color gc) color)) - (climi::with-transformed-position - ((sheet-native-transformation (medium-sheet medium)) - center-x center-y) - (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) - (radius-dy (abs (+ radius-1-dy radius-2-dy))) - (min-x (floor (- center-x radius-dx))) - (min-y (floor (- center-y radius-dy))) - (max-x (floor (+ center-x radius-dx))) - (max-y (floor (+ center-y radius-dy))) - (rect (coordinates->rectangle min-x min-y max-x max-y)) - (start-point - (gfs:make-point :x (floor (* (cos start-angle) radius-dx)) - :y (floor (* (sin start-angle) radius-dy)))) - (end-point - (gfs:make-point :x (floor (* (cos end-angle) radius-dx)) - :y (floor (* (sin end-angle) radius-dy))))) - (if filled - (gfg:draw-filled-pie-wedge gc rect start-point end-point) - (gfg:draw-arc gc rect start-point end-point))))) - (add-medium-to-render medium))) -|# - -;; FIXME: completely untested. (defmethod medium-draw-circle* ((medium graphic-forms-medium) center-x center-y radius start-angle end-angle filled)

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 01 Oct '07

01 Oct '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv23182 Modified Files: medium.lisp utils.lisp Log Message: fix calculation of start and end points for MEDIUM-DRAW-ELLIPSE* (and thus MEDIUM-DRAW-CIRCLE*) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/09/30 21:12:50 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/10/01 01:10:35 1.10 @@ -295,6 +295,78 @@ (gfg:draw-rectangle gc rect))))))))) (add-medium-to-render medium))) +(defun compute-quad-point (center-x height angle) + (let* ((opp-len (/ height 2)) + (hyp-len (/ opp-len (sin angle))) + (adj-len (sqrt (- (expt hyp-len 2) (expt opp-len 2))))) + (gfs:make-point :x (floor (+ center-x adj-len)) + :y (floor opp-len)))) + +(defun compute-arc-point (center-x center-y width height radians) + (let ((angle (radians->degrees radians))) + (multiple-value-bind (count remainder) + (floor angle 360) + (if (> count 0) + (compute-arc-point center-x center-y width height remainder) + (cond + ((= angle 270) + (gfs:make-point :x (floor center-x) + :y (+ (floor center-y) (floor height 2)))) + ((> angle 270) + (compute-quad-point center-x height (- angle 270))) + ((= angle 180) + (gfs:make-point :x (- (floor center-x) (floor width 2)) + :y (floor center-y))) + ((> angle 180) + (compute-quad-point center-x height (- angle 180))) + ((= angle 90) + (gfs:make-point :x (floor center-x) + :y (- (floor center-y) (floor height 2)))) + ((> angle 90) + (compute-quad-point center-x height(- angle 90))) + ((= angle 0) + (gfs:make-point :x (+ (floor center-x) (floor width 2)) + :y (floor center-y))) + (t + (compute-quad-point center-x height angle))))))) + +(defmethod medium-draw-ellipse* ((medium graphic-forms-medium) + center-x center-y + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy + start-angle end-angle + filled) + (unless (or (= radius-2-dx radius-1-dy 0) + (= radius-1-dx radius-2-dy 0)) + (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (if filled + (setf (gfg:background-color gc) color)) + (setf (gfg:foreground-color gc) color)) + (climi::with-transformed-position + ((sheet-native-transformation (medium-sheet medium)) + center-x center-y) + (let* ((width (abs (+ radius-1-dx radius-2-dx))) + (height (abs (+ radius-1-dy radius-2-dy))) + (min-x (floor (- center-x width))) + (min-y (floor (- center-y height))) + (max-x (floor (+ center-x width))) + (max-y (floor (+ center-y height))) + (rect (coordinates->rectangle min-x min-y max-x max-y)) + (start-pnt (compute-arc-point center-x center-y + width height + start-angle)) + (end-pnt (compute-arc-point center-x center-y + width height + end-angle))) + (if filled + (gfg:draw-filled-pie-wedge gc rect start-pnt end-pnt) + (gfg:draw-arc gc rect start-pnt end-pnt))))) + (add-medium-to-render medium))) + +#| ;; FIXME: completely untested. Not sure we're even using the right GFG h ;; functions. Are start-point and end-point right? (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y @@ -320,19 +392,16 @@ (max-y (floor (+ center-y radius-dy))) (rect (coordinates->rectangle min-x min-y max-x max-y)) (start-point - (gfs:make-point :x (floor - (* (cos start-angle) radius-dx)) - :y (floor - (* (sin start-angle) radius-dy)))) + (gfs:make-point :x (floor (* (cos start-angle) radius-dx)) + :y (floor (* (sin start-angle) radius-dy)))) (end-point - (gfs:make-point :x (floor - (* (cos end-angle) radius-dx)) - :y (floor - (* (sin end-angle) radius-dy))))) + (gfs:make-point :x (floor (* (cos end-angle) radius-dx)) + :y (floor (* (sin end-angle) radius-dy))))) (if filled (gfg:draw-filled-pie-wedge gc rect start-point end-point) - (gfg:draw-pie-wedge gc rect start-point end-point))))) + (gfg:draw-arc gc rect start-point end-point))))) (add-medium-to-render medium))) +|# ;; FIXME: completely untested. (defmethod medium-draw-circle* ((medium graphic-forms-medium) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/09/09 03:47:08 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/10/01 01:10:35 1.4 @@ -44,3 +44,7 @@ (loop for i from 0 below (length seq) by 2 collect (gfs:make-point :x (floor (elt seq i)) :y (floor (elt seq (+ i 1)))))) + +(declaim (inline radians->degrees)) +(defun radians->degrees (rads) + (floor (* rads 180) pi))

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 30 Sep '07

30 Sep '07

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23970/ESA Modified Files: esa.lisp Log Message: Removed MACRORECORD-PROCESSED-GESTURES-MIXIN from ASYNCHRONOUS-COMMAND-PROCESSOR superclass list, as Jack Unrue pointed out. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/29 13:27:26 1.9 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/30 22:03:54 1.10 @@ -468,8 +468,7 @@ finally (setf (executingp drei) nil))) (defclass asynchronous-command-processor (command-processor - instant-macro-execution-mixin - macrorecord-processed-gestures-mixin) + instant-macro-execution-mixin) () (:documentation "Helper class that provides behavior necessary for a command processor that expects to receive gestures through

1 0

[mcclim-cvs] CVS mcclim
by junrue 30 Sep '07

30 Sep '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12957 Modified Files: mcclim.asd Log Message: define new class graphic-forms-pixmap; separate a few pixmap-related methods from medium.lisp to the new pixmap.lisp --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/09/02 18:55:28 1.60 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/09/30 21:12:50 1.61 @@ -422,6 +422,7 @@ (:file "graft" :depends-on ("package")) (:file "port" :depends-on ("utils" "graft")) (:file "medium" :depends-on ("port")) + (:file "pixmap" :depends-on ("medium")) (:file "frame-manager" :depends-on ("medium")) (:file "gadgets" :depends-on ("port"))))))

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 30 Sep '07

30 Sep '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv12957/Backends/Graphic-Forms Modified Files: medium.lisp Added Files: pixmap.lisp Log Message: define new class graphic-forms-pixmap; separate a few pixmap-related methods from medium.lisp to the new pixmap.lisp --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/09/09 03:47:08 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/09/30 21:12:50 1.9 @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- -;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) +;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes(a)gold.ac.uk) @@ -55,6 +55,8 @@ (defun ink-to-color (medium ink) (cond + ((subtypep (class-of ink) (find-class 'climi::opacity)) + (setf ink (medium-foreground medium))) ; see discussion of opacity in design.lisp ((eql ink +foreground-ink+) (setf ink (medium-foreground medium))) ((eql ink +background-ink+) @@ -184,30 +186,6 @@ (defmethod (setf medium-line-style) :before (line-style (medium graphic-forms-medium)) ()) -(defmethod medium-copy-area ((from-drawable graphic-forms-medium) - from-x from-y width height - (to-drawable graphic-forms-medium) - to-x to-y) - nil) - -#+nil ; FIXME: PIXMAP class -(progn - (defmethod medium-copy-area ((from-drawable graphic-forms-medium) - from-x from-y width height - (to-drawable pixmap) - to-x to-y) - nil) - (defmethod medium-copy-area ((from-drawable pixmap) - from-x from-y width height - (to-drawable graphic-forms-medium) - to-x to-y) - ()) - (defmethod medium-copy-area ((from-drawable pixmap) - from-x from-y width height - (to-drawable pixmap) - to-x to-y) - ())) - (defmethod medium-draw-point* ((medium graphic-forms-medium) x y) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/pixmap.lisp 2007/09/30 21:12:50 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/pixmap.lisp 2007/09/30 21:12:50 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-pixmap (climi::mirrored-pixmap) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-medium) from-x from-y width height (to-drawable graphic-forms-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-medium) from-x from-y width height (to-drawable graphic-forms-pixmap) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-pixmap) from-x from-y width height (to-drawable graphic-forms-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-pixmap) from-x from-y width height (to-drawable graphic-forms-pixmap) to-x to-y) ())

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 30 Sep '07

30 Sep '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv12530 Modified Files: gadgets.lisp Log Message: fix errant initialization of menu divider label --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/09/02 19:00:58 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/09/30 21:05:51 1.5 @@ -54,7 +54,8 @@ (if (eql (command-menu-item-type thing) :command) (setf (gadget-label sub-pane) (climi::command-menu-item-name thing) (item sub-pane) thing) - (setf (label sub-pane) (climi::command-menu-item-name thing))) + (if (climi::command-menu-item-name thing) + (setf (label sub-pane) (climi::command-menu-item-name thing)))) (setf (sheet-parent sub-pane) menu-pane) (realize-mirror port sub-pane)))))) (dolist (menu-item (contents menu-pane))

1 0

[mcclim-cvs] CVS mcclim
by crhodes 29 Sep '07

29 Sep '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12842 Modified Files: NEWS Log Message: Fix a couple of bugs in ESA help commands relating to command tables and keystroke lookup. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/09/02 18:50:31 1.25 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/09/29 13:27:26 1.26 @@ -1,3 +1,7 @@ +* Changes in mcclim-0.9.6 relative to 0.9.5: +** Bug fix: ESA's help commands are better at finding bindings and + describing them + * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, and clouseau can now be loaded without loading the system mcclim

1 0

[mcclim-cvs] CVS mcclim/ESA
by crhodes 29 Sep '07

29 Sep '07

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv12842/ESA Modified Files: esa.lisp Log Message: Fix a couple of bugs in ESA help commands relating to command tables and keystroke lookup. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/27 11:03:21 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/29 13:27:26 1.9 @@ -1062,8 +1062,8 @@ when (eq (command-menu-item-type item) :command) do (return (values (command-menu-item-value item) gestures))))) -(defun describe-key-briefly (pane) - (let ((command-table (command-table pane))) +(defun describe-key-briefly (frame) + (let ((command-table (find-applicable-command-table frame))) (multiple-value-bind (command gestures) (read-gestures-for-help command-table) (when (consp command) @@ -1116,8 +1116,10 @@ #'(lambda (menu-name keystroke item) (declare (ignore menu-name)) (cond ((and (eq (command-menu-item-type item) :command) - (listp (command-menu-item-value item)) - (eq (car (command-menu-item-value item)) command)) + (or (and (symbolp (command-menu-item-value item)) + (eq (command-menu-item-value item) command)) + (and (listp (command-menu-item-value item)) + (eq (car (command-menu-item-value item)) command)))) (push (cons keystroke prefix) keystrokes)) ((eq (command-menu-item-type item) :menu) (helper command (command-menu-item-value item) (cons keystroke prefix))) @@ -1352,13 +1354,13 @@ "Prompt for a key and show the command it invokes." (display-message "Describe key briefly:") (redisplay-frame-panes *application-frame*) - (describe-key-briefly (car (windows *application-frame*)))) + (describe-key-briefly *application-frame*)) (set-key 'com-describe-key-briefly 'help-table '((#\h :control) (#\c))) (define-command (com-where-is :name t :command-table help-table) () "Prompt for a command name and show the key that invokes it." - (let* ((command-table (command-table (car (windows *application-frame*)))) + (let* ((command-table (find-applicable-command-table *application-frame*)) (command (handler-case (accept @@ -1383,7 +1385,7 @@ "Show which keys invoke which commands. Without a numeric prefix, sorts the list by command name. With a numeric prefix, sorts by key." (let ((stream (help-stream *application-frame* (format nil "Help: Describe Bindings"))) - (command-table (find-applicable-command-table *application-frame*))) + (command-table (find-applicable-command-table *application-frame*))) (describe-bindings stream command-table (if sort-by-keystrokes #'sort-by-keystrokes

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 27 Sep '07

27 Sep '07

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv31967 Modified Files: esa.lisp Log Message: Make C-g (and abort gestures in general) behave properly when they are part of a long gesture chain. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/05/23 14:41:48 1.7 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/27 11:03:21 1.8 @@ -467,19 +467,6 @@ do (process-gesture drei gesture) finally (setf (executingp drei) nil))) -(defclass macrorecord-processed-gestures-mixin () - () - (:documentation "Subclasses of this class will perform gesture -recording for macro recording when the gesture is being -processed. This is important when gesture reading does not go -through `esa-read-gesture', for example when the command -processor is being in an event-handling context.")) - -(defmethod process-gesture :before ((command-processor macrorecord-processed-gestures-mixin) gesture) - (when (and (recordingp command-processor) - (directly-processing-p command-processor)) - (push gesture (recorded-keys command-processor)))) - (defclass asynchronous-command-processor (command-processor instant-macro-execution-mixin macrorecord-processed-gestures-mixin) @@ -491,8 +478,9 @@ (defmethod process-gesture :before ((command-processor asynchronous-command-processor) gesture) (when (and (find gesture *abort-gestures* - :test #'gesture-matches-gesture-name-p) + :test #'gesture-matches-gesture-name-p) (directly-processing-p command-processor)) + (setf (accumulated-gestures command-processor) nil) (signal 'abort-gesture :event gesture))) (defclass command-loop-command-processor (command-processor) @@ -632,7 +620,16 @@ (defun substitute-numeric-argument-p (command numargp) (substitute numargp *numeric-argument-p* command :test #'eq)) -(defgeneric process-gestures (command-processor)) +(defgeneric process-gestures (command-processor) + (:documentation "Process the gestures accumulated in +`command-processor', returning T if there are no gestures +accumulated or the accumulated gestures correspond to a +command. In this case, the command will also be executed and the +list of accumulated gestures set to NIL. Will return NIL if the +accumulated gestures do not yet correspond to a command, but +eventually could, if more gestures are provided. Signals +`unbound-gesture-sequence' if the accumulated gestures could +never refer to a command.")) (defmethod process-gestures ((command-processor command-processor)) (multiple-value-bind (prefix-arg prefix-p gestures) @@ -660,7 +657,13 @@ *partial-command-parser* (command-table command-processor) *standard-input* command 0))) - (setf (accumulated-gestures command-processor) nil)) + ;; If we are macrorecording, store whatever the user + ;; did to invoke this command. + (when (recordingp command-processor) + (setf (recorded-keys command-processor) + (append (accumulated-gestures command-processor) + (recorded-keys command-processor)))) + (setf (accumulated-gestures command-processor) nil)) (funcall (command-executor command-processor) command-processor command) nil)) (t t))))))) @@ -686,14 +689,15 @@ (loop for gesture = (read-gesture :stream stream) until (proper-gesture-p gesture) - finally (progn (when (recordingp command-processor) - (push gesture (recorded-keys command-processor))) - (return gesture)))) + finally (return gesture))) (defun esa-unread-gesture (gesture &key (command-processor *command-processor*) (stream *standard-input*)) (cond ((recordingp command-processor) - (pop (recorded-keys command-processor)) + (cond ((equal (first (recorded-keys command-processor)) gesture) + (pop (recorded-keys command-processor))) + ((equal (first (accumulated-gestures command-processor)) gesture) + (pop (accumulated-gestures command-processor)))) (unread-gesture gesture :stream stream)) ((executingp command-processor) (push gesture (remaining-keys command-processor))) @@ -735,6 +739,14 @@ (funcall (command-executor command-processor) command-processor command))))) +(defmethod process-gestures-or-command :around ((command-processor command-processor)) + (handler-case (call-next-method) + (abort-gesture (c) + ;; If the user aborts, we want to forget whatever previous + ;; gestures he entered since the last command execution. + (setf (accumulated-gestures command-processor) nil) + (signal c)))) + (defmethod process-gestures-or-command ((command-processor command-processor)) ;; Build up a list of gestures and repeatedly pass them to ;; `process-gestures'. This "clumsy" approach is chosen because we @@ -743,7 +755,8 @@ ;; rescanning of accumulated input data or some yet-unimplemented ;; complex state retaining mechanism (such as continuations). (loop - (setf *current-gesture* (esa-read-gesture :command-processor command-processor)) + (setf *current-gesture* + (esa-read-gesture :command-processor command-processor)) (unless (process-gesture command-processor *current-gesture*) (return))))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs