Author: junrue Date: Sat Apr 8 01:34:22 2006 New Revision: 93
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: even better selection behavior in the unblocked demo
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sat Apr 8 01:34:22 2006 @@ -104,6 +104,7 @@ (gfg:draw-text gc value-text text-pnt)))
(defmethod update-buffer ((self scoreboard-panel-events) tiles) + (declare (ignore tiles)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (label-font (label-font-of self)) (value-font (value-font-of self))
Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sat Apr 8 01:34:22 2006 @@ -52,27 +52,26 @@ nil (gfs:make-point :x xpos :y ypos))))
-(defclass tiles-timer-events (gfw:event-dispatcher) - ((panel-dispatcher - :accessor panel-dispatcher - :initarg :panel-dispatcher - :initform nil))) - -(defmethod gfw:event-timer ((self tiles-timer-events) timer time) - (declare (ignore timer time)) - (let ((tiles (model-tiles))) - (collapse-tiles tiles) - (update-buffer (panel-dispatcher self) tiles) - (gfw:redraw (get-tiles-panel)))) - (defclass tiles-panel-events (double-buffered-event-dispatcher) ((tile-image-table :accessor tile-image-table-of :initform (make-hash-table :test #'equal)) - (mouse-tile - :accessor mouse-tile-of + (shape-kind + :accessor shape-kind-of + :initform 0) + (shape-pnts + :accessor shape-pnts-of :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)))) + (defmethod dispose ((self tiles-panel-events)) (let ((table (tile-image-table-of self))) (maphash #'(lambda (kind image) @@ -80,6 +79,7 @@ (gfs:dispose image)) table)) (setf (tile-image-table-of self) nil) + (setf (shape-pnts-of self) nil) (call-next-method))
(defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) @@ -94,38 +94,45 @@ (incf kind)))))
(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) - (declare (ignore panel time)) - (let ((tile-pnt (window->tiles point))) - (if (and (eql button :left-button) (not (null tile-pnt))) - (setf (mouse-tile-of self) tile-pnt) - (setf (mouse-tile-of self) nil)))) + (declare (ignore time)) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (tile-kind (obtain-tile tiles tile-pnt)) + (shape-pnts (shape-pnts-of self)) + (tmp-table (make-hash-table :test #'equalp))) + (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point)) + (draw-tiles-directly panel shape-pnts (shape-kind-of self)) + (setf (shape-pnts-of self) nil) + (setf (shape-kind-of self) 0)) + (setf shape-pnts nil) + (if (and (eql button :left-button) (> tile-kind 0)) + (shape-tiles tiles tile-pnt tmp-table)) + (when (> (hash-table-count tmp-table) 1) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (push pnt shape-pnts)) + tmp-table) + (setf (shape-kind-of self) tile-kind) + (setf (shape-pnts-of self) shape-pnts) + (draw-tiles-directly panel shape-pnts +max-tile-kinds+))))
(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let ((tile-pnt (window->tiles point)) - (tiles (model-tiles))) - (if (and (eql button :left-button) (not (null tile-pnt)) (eql-point tile-pnt (mouse-tile-of self))) - (let ((results (make-hash-table :test #'equalp))) - (unless (= (obtain-tile tiles tile-pnt) 0) - (shape-tiles tiles tile-pnt results) - (when (> (hash-table-count results) 1) - (let ((gc (make-instance 'gfg:graphics-context :widget panel)) - (image-table (tile-image-table-of self))) - (unwind-protect - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt 0) - (gfg:draw-image gc - (gethash +max-tile-kinds+ image-table) - (tiles->window pnt))) - results) - (gfs:dispose gc))) - (gfw:start (make-instance 'gfw:timer - :initial-delay 100 - :delay 0 - :dispatcher (make-instance 'tiles-timer-events - :panel-dispatcher self))))))) - (setf (mouse-tile-of self) nil))) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (shape-pnts (shape-pnts-of self))) + (if (and (eql button :left-button) + shape-pnts + (find tile-pnt shape-pnts :test #'eql-point)) + (progn + (loop for pnt in shape-pnts do (set-tile tiles pnt 0)) + (collapse-tiles tiles) + (update-buffer (gfw:dispatcher panel) tiles) + (gfw:redraw panel)) + (if shape-pnts + (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) + (setf (shape-kind-of self) 0) + (setf (shape-pnts-of self) nil))
(defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sat Apr 8 01:34:22 2006 @@ -69,6 +69,8 @@ (= (gfs:point-y pnt1) (gfs:point-y pnt2))))
(defun obtain-tile (tiles pnt) + (if (null pnt) + (return-from obtain-tile 0)) (let ((column (aref tiles (gfs:point-x pnt)))) (aref column (gfs:point-y pnt))))
@@ -92,7 +94,7 @@ (neighbor-point tiles orig-pnt 0 1) (neighbor-point tiles orig-pnt -1 0) (neighbor-point tiles orig-pnt 1 0)) - when (not (null pnt)) + when pnt collect pnt))
(defun shape-tiles (tiles tile-pnt results)
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Apr 8 01:34:22 2006 @@ -334,7 +334,7 @@ (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (if (not (null (transparency-pixel-of im))) + (if (transparency-pixel-of im) (progn (setf tr-mask (transparency-mask im)) (let ((hmask (gfs:handle tr-mask))
Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sat Apr 8 01:34:22 2006 @@ -211,7 +211,7 @@ (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) - (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (when (and handle (not (cffi:null-pointer-p handle))) (destroy-image handle) (setf (slot-value data 'gfs:handle) nil) (setf handle nil))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sat Apr 8 01:34:22 2006 @@ -102,18 +102,18 @@ (sub-tmp nil)) (loop for opt in form do (cond - ((not (null cb-tmp)) + (cb-tmp (setf callback opt) (setf cb-tmp nil) (setf disp nil)) - ((not (null disp-tmp)) + (disp-tmp (setf disp opt) (setf disp-tmp nil) (setf callback nil)) - ((not (null image-tmp)) + (image-tmp (setf image opt) (setf image-tmp nil)) - ((not (null sub-tmp)) + (sub-tmp (setf sub opt) (setf sub-tmp nil)) ((and (not (eq opt :item)) (null label))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Apr 8 01:34:22 2006 @@ -134,7 +134,7 @@ (setf style (list style))) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (not (null (find :workspace style))) + (when (find :workspace style) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func style owner title)))