[graphic-forms-cvs] r93 - in trunk/src: demos/unblocked uitoolkit/graphics uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sat Apr 8 05:34:23 UTC 2006
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)))
More information about the Graphic-forms-cvs
mailing list