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)