[graphic-forms-cvs] r272 - in trunk/src: demos/unblocked uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Wed Sep 27 05:08:41 UTC 2006
Author: junrue
Date: Wed Sep 27 01:08:38 2006
New Revision: 272
Modified:
trunk/src/demos/unblocked/scoreboard-panel.lisp
trunk/src/demos/unblocked/unblocked-controller.lisp
trunk/src/demos/unblocked/unblocked-model.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
Log:
generate a new set of tiles on reaching the next level; provide a bit of feedback when asked to reveal next move
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/scoreboard-panel.lisp (original)
+++ trunk/src/demos/unblocked/scoreboard-panel.lisp Wed Sep 27 01:08:38 2006
@@ -112,8 +112,8 @@
(unwind-protect
(progn
(clear-buffer self gc)
- (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score))
- (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level))
+ (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (model-score))
+ (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (model-level))
(draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed)))
(gfs:dispose gc))))
Modified: trunk/src/demos/unblocked/unblocked-controller.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-controller.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-controller.lisp Wed Sep 27 01:08:38 2006
@@ -47,13 +47,20 @@
(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)))))
+ (cond
+ (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)))
+ (t
+ (gfs::message-box (gfs:handle (get-unblocked-win))
+ "There are no remaining shapes."
+ "Sorry!"
+ (logior gfs::+mb-ok+ gfs::+mb-iconinformation+)
+ 0)))))
(defun ctrl-start-selection (shape-pnts panel point button)
(let* ((tiles (model-tiles))
@@ -75,8 +82,11 @@
(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)
+ (let ((prev-level (model-level)))
+ (update-model-score shape-pnts)
+ (if (> (model-level) prev-level)
+ (regenerate-model-tiles)
+ (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 Wed Sep 27 01:08:38 2006
@@ -85,21 +85,26 @@
(defun model-tiles ()
(active-tiles-of *game*))
+(defun update-model-score (shape-data)
+ (incf (score-of *game*) (* 5 (length shape-data))))
+
(defun update-model-tiles (shape-data)
(setf (active-tiles-of *game*)
(if shape-data
(progn
- (incf (score-of *game*) (* 5 (length shape-data)))
(loop with tmp = (clone-tiles (active-tiles-of *game*))
for pnt in shape-data do (set-tile tmp pnt 0)
finally (return (collapse-tiles tmp))))
(original-tiles-of *game*))))
-(defun game-level ()
+(defun regenerate-model-tiles ()
+ (setf (active-tiles-of *game*) (compute-new-game-tiles)))
+
+(defun model-level ()
(lookup-level-reached (score-of *game*)))
(defun game-points-needed ()
- (- (nth (1- (game-level)) *points-needed-table*) (score-of *game*)))
+ (- (nth (1- (model-level)) *points-needed-table*) (score-of *game*)))
-(defun game-score ()
+(defun model-score ()
(score-of *game*))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Wed Sep 27 01:08:38 2006
@@ -597,6 +597,38 @@
(defconstant +lr-copyfromresource+ #x4000)
(defconstant +lr-shared+ #x8000)
+(defconstant +mb-ok+ #x00000000)
+(defconstant +mb-okcancel+ #x00000001)
+(defconstant +mb-abortretryignore+ #x00000002)
+(defconstant +mb-yesnocancel+ #x00000003)
+(defconstant +mb-yesno+ #x00000004)
+(defconstant +mb-retrycancel+ #x00000005)
+(defconstant +mb-canceltrycontinue+ #x00000006)
+(defconstant +mb-iconhand+ #x00000010)
+(defconstant +mb-iconquestion+ #x00000020)
+(defconstant +mb-iconexclamation+ #x00000030)
+(defconstant +mb-iconasterisk+ #x00000040)
+(defconstant +mb-usericon+ #x00000080)
+(defconstant +mb-iconwarning+ #x00000030)
+(defconstant +mb-iconerror+ #x00000010)
+(defconstant +mb-iconinformation+ #x00000040)
+(defconstant +mb-iconstop+ #x00000010)
+(defconstant +mb-defbutton1+ #x00000000)
+(defconstant +mb-defbutton2+ #x00000100)
+(defconstant +mb-defbutton3+ #x00000200)
+(defconstant +mb-defbutton4+ #x00000300)
+(defconstant +mb-applmodal+ #x00000000)
+(defconstant +mb-systemmodal+ #x00001000)
+(defconstant +mb-taskmodal+ #x00002000)
+(defconstant +mb-help+ #x00004000)
+(defconstant +mb-nofocus+ #x00008000)
+(defconstant +mb-setforeground+ #x00010000)
+(defconstant +mb-default-desktop-only+ #x00020000)
+(defconstant +mb-topmost+ #x00040000)
+(defconstant +mb-right+ #x00080000)
+(defconstant +mb-rtlreading+ #x00100000)
+(defconstant +mb-service-notification+ #x00200000)
+
(defconstant +mf-bycommand+ #x00000000)
(defconstant +mf-byposition+ #x00000400)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Wed Sep 27 01:08:38 2006
@@ -570,6 +570,15 @@
(type UINT))
(defcfun
+ ("MessageBoxExA" message-box)
+ INT
+ (hwnd HANDLE)
+ (text :string)
+ (caption :string)
+ (type UINT)
+ (langid WORD))
+
+(defcfun
("MonitorFromWindow" monitor-from-window)
HANDLE
(hwnd HANDLE)
More information about the Graphic-forms-cvs
mailing list