[graphic-forms-cvs] r271 - in trunk: . docs/website src/demos/unblocked
junrue at common-lisp.net
junrue at common-lisp.net
Wed Sep 27 02:58:15 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list