Author: junrue Date: Tue Sep 26 22:58:14 2006 New Revision: 271 Added: trunk/src/demos/unblocked/unblocked-controller.lisp Modified: trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: separated controller code from window and panel code Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Sep 26 22:58:14 2006 @@ -64,7 +64,7 @@ <ul> <li><a href="http://clisp.cons.org/">CLISP 2.38 or later</a></li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> - <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15</a></li> + <li><a href="http://www.sbcl.org/">SBCL 0.9.15</a></li> </ul> <p>The supported Windows versions are: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Tue Sep 26 22:58:14 2006 @@ -75,6 +75,7 @@ :components ((:file "tiles") (:file "unblocked-model") + (:file "unblocked-controller") (:file "double-buffered-event-dispatcher") (:file "scoreboard-panel") (:file "tiles-panel") Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Tue Sep 26 22:58:14 2006 @@ -93,35 +93,21 @@ (incf kind))))) (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button) - (let* ((tiles (game-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) - (gfw:capture-mouse panel) - (setf (shape-kind-of self) tile-kind) - (setf (shape-pnts-of self) (shape-tile-points tmp-table)) - (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) + (multiple-value-bind (shape-kind shape-pnts) + (ctrl-start-selection (shape-pnts-of self) panel point button) + (if shape-pnts + (progn + (setf (shape-kind-of self) shape-kind + (shape-pnts-of self) shape-pnts) + (gfw:capture-mouse panel)) + (progn + (draw-tiles-directly panel (shape-pnts-of self) (shape-kind-of self)) + (setf (shape-kind-of self) 0) + (setf (shape-pnts-of self) nil))))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button) (gfw:release-mouse) - (let ((tile-pnt (window->tiles point)) - (shape-pnts (shape-pnts-of self))) - (when (and (eql button :left-button) shape-pnts) - (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (progn - (update-game-tiles shape-pnts) - (update-panel (get-scoreboard-panel)) - (update-panel (get-tiles-panel))) - (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) + (ctrl-finish-selection (shape-pnts-of self) (shape-kind-of self) panel point button) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) @@ -132,7 +118,7 @@ (map-tiles #'(lambda (pnt kind) (unless (= kind 0) (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles))))) + (model-tiles))))) (defclass tiles-panel (gfw:panel) ()) Added: trunk/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-controller.lisp Tue Sep 26 22:58:14 2006 @@ -0,0 +1,82 @@ +;;;; +;;;; unblocked-controller.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +revealed-duration+ 2000) ; millis + +(defun ctrl-start-game () + (model-new) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + +(defun ctrl-restart-game () + (model-rollback) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + +(defun ctrl-reveal-move () + (let ((shape (find-shape (model-tiles) #'accept-shape-p))) + (when shape + (let ((shape-pnts (shape-tile-points shape)) + (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ + :delay 0 + :dispatcher (gfw:dispatcher (get-unblocked-win))))) + (draw-tiles-directly (get-tiles-panel) shape-pnts +max-tile-kinds+) + (gfw:enable timer t))))) + +(defun ctrl-start-selection (shape-pnts panel point button) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (tile-kind (obtain-tile tiles tile-pnt)) + (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 tile-kind)) + (if (and (eql button :left-button) (> tile-kind 0)) + (shape-tiles tiles tile-pnt tmp-table)) + (cond + ((> (hash-table-count tmp-table) 1) + (let ((shape-pnts (shape-tile-points tmp-table))) + (draw-tiles-directly panel shape-pnts +max-tile-kinds+) + (values tile-kind shape-pnts))) + (t (values nil nil))))) + +(defun ctrl-finish-selection (shape-pnts shape-kind panel point button) + (let ((tile-pnt (window->tiles point))) + (when (and (eql button :left-button) shape-pnts) + (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) + (progn + (update-model-tiles shape-pnts) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + (draw-tiles-directly panel shape-pnts shape-kind))))) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Tue Sep 26 22:58:14 2006 @@ -51,6 +51,11 @@ (defun compute-new-game-tiles () (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))) +(defun accept-shape-p (shape) + (let ((size (shape-size shape)) + (kind (shape-kind shape))) + (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (defclass unblocked-game-model () ((score :accessor score-of @@ -67,20 +72,20 @@ (defvar *game* (make-instance 'unblocked-game-model)) -(defun new-game () +(defun model-new () (let ((tiles (compute-new-game-tiles))) (setf (score-of *game*) 0 (original-tiles-of *game*) tiles (active-tiles-of *game*) tiles))) -(defun restart-game () +(defun model-rollback () (setf (score-of *game*) 0 (active-tiles-of *game*) (original-tiles-of *game*))) -(defun game-tiles () +(defun model-tiles () (active-tiles-of *game*)) -(defun update-game-tiles (shape-data) +(defun update-model-tiles (shape-data) (setf (active-tiles-of *game*) (if shape-data (progn Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Tue Sep 26 22:58:14 2006 @@ -36,12 +36,13 @@ (defconstant +spacing+ 4) (defconstant +margin+ 4) -(defconstant +revealed-duration+ 2000) ; millis - (defvar *scoreboard-panel* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) +(defun get-unblocked-win () + *unblocked-win*) + (defun get-tiles-panel () *tiles-panel*) @@ -50,20 +51,11 @@ (defun new-unblocked (disp item) (declare (ignore disp item)) - (new-game) - (update-panel *scoreboard-panel*) - (update-panel *tiles-panel*)) + (ctrl-start-game)) (defun restart-unblocked (disp item) (declare (ignore disp item)) - (restart-game) - (update-panel *scoreboard-panel*) - (update-panel *tiles-panel*)) - -(defun accept-shape-p (shape) - (let ((size (shape-size shape)) - (kind (shape-kind shape))) - (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (ctrl-restart-game)) (defun update-panel (panel) (update-buffer (gfw:dispatcher panel)) @@ -71,14 +63,7 @@ (defun reveal-unblocked (disp item) (declare (ignore disp item)) - (let ((shape (find-shape (game-tiles) #'accept-shape-p))) - (when shape - (let ((shape-pnts (shape-tile-points shape)) - (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ - :delay 0 - :dispatcher (gfw:dispatcher *unblocked-win*)))) - (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) - (gfw:enable timer t))))) + (ctrl-reveal-move)) (defun quit-unblocked (disp item) (declare (ignore disp item))