[graphic-forms-cvs] r159 - trunk/src/demos/unblocked
junrue at common-lisp.net
junrue at common-lisp.net
Sun Jun 25 23:22:53 UTC 2006
Author: junrue
Date: Sun Jun 25 19:22:52 2006
New Revision: 159
Modified:
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/tiles.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
Log:
implemented reveal-unblocked
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jun 25 19:22:52 2006
@@ -110,13 +110,9 @@
(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+))))
+ (setf (shape-pnts-of self) (shape-tile-points tmp-table))
+ (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+))))
(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button)
(declare (ignore time))
Modified: trunk/src/demos/unblocked/tiles.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles.lisp (original)
+++ trunk/src/demos/unblocked/tiles.lisp Sun Jun 25 19:22:52 2006
@@ -110,6 +110,28 @@
when (= kind (obtain-tile tiles pnt2))
do (shape-tiles tiles pnt2 results)))))
+(defun shape-tile-points (shape)
+ (let ((shape-pnts nil))
+ (maphash (lambda (pnt kind)
+ (declare (ignore kind))
+ (push pnt shape-pnts))
+ shape)
+ shape-pnts))
+
+(defun shape-size (shape)
+ (hash-table-count shape))
+
+(defun shape-kind (shape)
+ (if (null shape)
+ (return-from shape-kind 0))
+ (let ((kind nil))
+ (maphash (lambda (pnt k)
+ (declare (ignore pnt))
+ (if (null kind)
+ (setf kind k)))
+ shape)
+ kind))
+
(defun collapse-column (column-tiles)
(let ((new-column (make-array (length column-tiles) :initial-element 0))
(new-index 0)
@@ -133,3 +155,37 @@
(dotimes (i width)
(setf (aref new-tiles i) (copy-seq (aref orig-tiles i))))
new-tiles))
+
+(defun find-shape (tiles accept-p)
+ (if (null *unblocked-random-state*)
+ (setf *unblocked-random-state* (make-random-state)))
+ (let ((*random-state* *unblocked-random-state*)
+ (candidate-shapes nil))
+ (dotimes (col-index (length tiles))
+ (let ((column-tiles (aref tiles col-index)))
+ (dotimes (tile-index (length column-tiles))
+ (let ((shape (make-hash-table :test #'equalp)))
+ (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) shape)
+ (if (funcall accept-p shape)
+ (push shape candidate-shapes))))))
+ (unless candidate-shapes
+ (return-from find-shape nil))
+ (elt candidate-shapes (random (length candidate-shapes)))))
+
+#|
+(defun find-shape (tiles accept-p)
+ (if (null *unblocked-random-state*)
+ (setf *unblocked-random-state* (make-random-state)))
+ (let ((*random-state* *unblocked-random-state*)
+ (shape nil))
+ (loop for col-index = (random (length tiles))
+ for column-tiles = (aref tiles col-index)
+ for tile-index = (random (length column-tiles))
+ for tmp-shape = (make-hash-table :test #'equalp)
+ until shape
+ do (progn
+ (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) tmp-shape)
+ (if (and (> (shape-size tmp-shape) 1) (funcall accept-p tmp-shape))
+ (setf shape tmp-shape))))
+ shape))
+|#
\ No newline at end of file
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jun 25 19:22:52 2006
@@ -33,8 +33,10 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +spacing+ 4)
-(defconstant +margin+ 4)
+(defconstant +spacing+ 4)
+(defconstant +margin+ 4)
+
+(defconstant +revealed-duration+ 2000) ; millis
(defvar *scoreboard-panel* nil)
(defvar *unblocked-startup-dir* nil)
@@ -62,8 +64,21 @@
(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+))))
+
(defun reveal-unblocked (disp item time rect)
- (declare (ignore disp item time rect)))
+ (declare (ignore disp item time rect))
+ (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)))))
(defun quit-unblocked (disp item time rect)
(declare (ignore disp item time rect))
@@ -79,6 +94,10 @@
(declare (ignore window time))
(quit-unblocked disp nil nil nil))
+(defmethod gfw:event-timer ((disp unblocked-win-events) timer time)
+ (declare (ignore timer time))
+ (update-panel *tiles-panel*))
+
(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ())
(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time)
More information about the Graphic-forms-cvs
mailing list