[graphic-forms-cvs] r454 - in branches/graphic-forms-newtypes/src: demos/unblocked uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sun Apr  1 00:30:17 2007
New Revision: 454

Modified:
   branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp
   branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp
   branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp
Log:
implemented text and (setf text) for status-bar; unblocked now displays shape count and points scored via status-bar messages

Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp	(original)
+++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp	Sun Apr  1 00:30:17 2007
@@ -1,7 +1,7 @@
 ;;;;
 ;;;; unblocked-controller.lisp
 ;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
 ;;;; All rights reserved.
 ;;;;
 ;;;; Redistribution and use in source and binary forms, with or without
@@ -37,11 +37,13 @@
 
 (defun ctrl-start-game ()
   (model-new)
+  (update-status-bar "Ready.")
   (update-panel (get-scoreboard-panel))
   (update-panel (get-tiles-panel)))
 
 (defun ctrl-restart-game ()
   (model-rollback)
+  (update-status-bar "Ready.")
   (update-panel (get-scoreboard-panel))
   (update-panel (get-tiles-panel)))
 
@@ -82,10 +84,17 @@
   (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))
-        (let ((prev-level (model-level)))
+        (let ((prev-level (model-level))
+              (orig-score (score-of *game*)))
           (update-model-score shape-pnts)
+          (update-status-bar (format nil
+                                     "Removed ~d tiles for ~d points."
+                                     (length shape-pnts)
+                                     (- (score-of *game*) orig-score)))
           (if (> (model-level) prev-level)
-            (regenerate-model-tiles)
+            (progn
+              (regenerate-model-tiles)
+              (update-status-bar "Ready."))
             (update-model-tiles shape-pnts))
           (update-panel (get-scoreboard-panel))
           (update-panel (get-tiles-panel)))

Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp	(original)
+++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp	Sun Apr  1 00:30:17 2007
@@ -61,6 +61,10 @@
   (update-buffer (gfw:dispatcher panel))
   (gfw:redraw panel))
 
+(defun update-status-bar (msg)
+  (if *unblocked-win*
+    (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg)))
+
 (defun reveal-unblocked (disp item)
   (declare (ignore disp item))
   (ctrl-reveal-move))
@@ -129,7 +133,8 @@
 
     (new-unblocked nil nil)
     (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)))
-      (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico"))))
+      (setf (gfw:image *unblocked-win*)
+            (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico"))))
     (gfw:show *unblocked-win* t)))
 
 (defun unblocked ()

Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp	Sun Apr  1 00:30:17 2007
@@ -127,3 +127,9 @@
         (widths (stb-get-border-widths self)))
     (gfs:make-size :width 0
                    :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1))))
+
+(defmethod text ((sbar status-bar))
+  (stb-get-text sbar 0))
+
+(defmethod (setf text) (str (sbar status-bar))
+  (stb-set-text sbar str))