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))