[graphic-forms-cvs] r159 - trunk/src/demos/unblocked

[junrue at common-lisp.net]

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)