[graphic-forms-cvs] r88 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Apr 4 01:56:19 UTC 2006
Author: junrue
Date: Mon Apr 3 21:56:18 2006
New Revision: 88
Modified:
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/tiles.lisp
trunk/src/demos/unblocked/unblocked-model.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/brown-tile.bmp
trunk/src/uitoolkit/widgets/event.lisp
Log:
additional image/graphics-context testing by virtue of implementing selected tile highlighting
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 21:56:18 2006
@@ -37,12 +37,19 @@
(defconstant +tile-bmp-height+ 24)
(defun tiles->window (pnt)
- (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+)
- :y (* (gfs:point-y pnt) +tile-bmp-height+)))
+ (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+))
+ (ypos (* (gfs:point-y pnt) +tile-bmp-height+))
+ (size (gfw:client-size (get-tiles-panel))))
+ (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size)))
+ nil
+ (gfs:make-point :x xpos :y ypos))))
(defun window->tiles (pnt)
- (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+))
- :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+))))
+ (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+)))
+ (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+))))))
+ (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+))
+ nil
+ (gfs:make-point :x xpos :y ypos))))
(defclass tiles-panel-events (gfw:event-dispatcher)
((image-buffer
@@ -53,7 +60,10 @@
+tile-bmp-height+))))
(tile-image-table
:accessor tile-image-table-of
- :initform (make-hash-table :test #'equal))))
+ :initform (make-hash-table :test #'equal))
+ (mouse-tile
+ :accessor mouse-tile-of
+ :initform nil)))
(defmethod dispose ((self tiles-panel-events))
(let ((image (image-buffer-of self))
@@ -73,13 +83,37 @@
(defmethod initialize-instance :after ((self tiles-panel-events) &key)
(let ((table (tile-image-table-of self))
(kind 1))
- (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp"
- "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp")
+ (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp"
+ "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp")
do (let ((image (make-instance 'gfg:image)))
(gfg:load image filename)
(setf (gethash kind table) image)
(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))))
+
+(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)
+ (maphash #'(lambda (pnt kind)
+ (declare (ignore kind))
+ (set-tile tiles pnt +max-tile-kinds+))
+ results)
+ (update-buffer self tiles)
+ (gfw:redraw panel)))))
+ (setf (mouse-tile-of self) nil)))
+
(defmethod update-buffer ((self tiles-panel-events) tiles)
(let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
(image-table (tile-image-table-of self))
Modified: trunk/src/demos/unblocked/tiles.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles.lisp (original)
+++ trunk/src/demos/unblocked/tiles.lisp Mon Apr 3 21:56:18 2006
@@ -72,6 +72,10 @@
(let ((column (aref tiles (gfs:point-x pnt))))
(aref column (gfs:point-y pnt))))
+(defun set-tile (tiles pnt kind)
+ (let ((column (aref tiles (gfs:point-x pnt))))
+ (setf (aref column (gfs:point-y pnt)) kind)))
+
(defun neighbor-point (tiles orig-pnt delta-x delta-y)
(let ((size (size-tiles tiles))
(new-x (+ (gfs:point-x orig-pnt) delta-x))
Modified: trunk/src/demos/unblocked/unblocked-model.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-model.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Apr 3 21:56:18 2006
@@ -35,6 +35,15 @@
(defconstant +max-tile-kinds+ 6)
+(defvar *tiles* nil)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +horz-tile-count+ 14)
(defconstant +vert-tile-count+ 9))
+
+(defun init-model-tiles ()
+ (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))
+ *tiles*)
+
+(defun model-tiles ()
+ *tiles*)
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 3 21:56:18 2006
@@ -40,10 +40,16 @@
(defvar *tiles-panel* nil)
(defvar *unblocked-win* nil)
+(defun get-tiles-panel ()
+ *tiles-panel*)
+
+(defun get-scoreboard-panel ()
+ *scoreboard-panel*)
+
(defun new-unblocked (disp item time rect)
(declare (ignore disp item time rect))
(let ((tiles-disp (gfw:dispatcher *tiles-panel*))
- (tiles (init-tiles +horz-tile-count+ +vert-tile-count+ 5)))
+ (tiles (init-model-tiles)))
(collapse-tiles tiles)
(update-buffer tiles-disp tiles)
(gfw:redraw *tiles-panel*)))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Apr 3 21:56:18 2006
@@ -232,12 +232,9 @@
#:window
;; constants
- #:left-button ;; FIXME: should be a keyword
#:maximized ;; FIXME: should be a keyword
- #:middle-button ;; FIXME: should be a keyword
#:minimized ;; FIXME: should be a keyword
#:restored ;; FIXME: should be a keyword
- #:right-button ;; FIXME: should be a keyword
#:+vk-break+
#:+vk-backspace+
#:+vk-tab+
Modified: trunk/src/tests/uitoolkit/brown-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Mon Apr 3 21:56:18 2006
@@ -232,37 +232,37 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-double hwnd lparam 'left-button))
+ (process-mouse-message #'event-mouse-double hwnd lparam :left-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondown+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-down hwnd lparam 'left-button))
+ (process-mouse-message #'event-mouse-down hwnd lparam :left-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttonup+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-up hwnd lparam 'left-button))
+ (process-mouse-message #'event-mouse-up hwnd lparam :left-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondblclk+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-double hwnd lparam 'middle-button))
+ (process-mouse-message #'event-mouse-double hwnd lparam :middle-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondown+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-down hwnd lparam 'middle-button))
+ (process-mouse-message #'event-mouse-down hwnd lparam :middle-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttonup+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-up hwnd lparam 'middle-button))
+ (process-mouse-message #'event-mouse-up hwnd lparam :middle-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-mousemove+)) wparam lparam)
- (let ((btn-sym 'left-button))
+ (let ((btn-sym :left-button))
(cond
((= (logand wparam gfs::+mk-mbutton+) gfs::+mk-mbutton+)
- (setf btn-sym 'middle-button))
+ (setf btn-sym :middle-button))
((= (logand wparam gfs::+mk-rbutton+) gfs::+mk-rbutton+)
- (setf btn-sym 'right-button))
+ (setf btn-sym :right-button))
(t
- (setf btn-sym 'left-button)))
+ (setf btn-sym :left-button)))
(process-mouse-message #'event-mouse-move hwnd lparam btn-sym)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam)
@@ -308,15 +308,15 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-double hwnd lparam 'right-button))
+ (process-mouse-message #'event-mouse-double hwnd lparam :right-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondown+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-down hwnd lparam 'right-button))
+ (process-mouse-message #'event-mouse-down hwnd lparam :right-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttonup+)) wparam lparam)
(declare (ignore wparam))
- (process-mouse-message #'event-mouse-up hwnd lparam 'right-button))
+ (process-mouse-message #'event-mouse-up hwnd lparam :right-button))
(defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam)
(declare (ignore lparam))
More information about the Graphic-forms-cvs
mailing list