[graphic-forms-cvs] r94 - in trunk: . src/demos/unblocked
junrue at common-lisp.net
junrue at common-lisp.net
Sun Apr 9 18:02:37 UTC 2006
Author: junrue
Date: Sun Apr 9 14:02:36 2006
New Revision: 94
Modified:
trunk/build.lisp
trunk/config.lisp
trunk/graphic-forms-tests.asd
trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
trunk/src/demos/unblocked/scoreboard-panel.lisp
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/tiles.lisp
trunk/src/demos/unblocked/unblocked-model.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
Log:
now using Cells experimentally as the data model for the unblocked demo
Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp (original)
+++ trunk/build.lisp Sun Apr 9 14:02:36 2006
@@ -44,6 +44,7 @@
(defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/"))
(defvar *project-root* "c:/projects/public/")
+(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/"))
(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/"))
(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/"))
(setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/")
Modified: trunk/config.lisp
==============================================================================
--- trunk/config.lisp (original)
+++ trunk/config.lisp Sun Apr 9 14:02:36 2006
@@ -37,6 +37,7 @@
(in-package #:graphic-forms-system)
+(defvar *cells-dir* "cells/")
(defvar *cffi-dir* "cffi-0.9.0/")
(defvar *closer-mop-dir* "closer-mop/")
(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/")
@@ -51,6 +52,7 @@
`(ext:cd ,path))
(defun configure-asdf ()
+ (pushnew *cells-dir* asdf:*central-registry* :test #'equal)
(pushnew *cffi-dir* asdf:*central-registry* :test #'equal)
(pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal)
(pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal))
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Sun Apr 9 14:02:36 2006
@@ -54,6 +54,7 @@
:version "0.2.0"
:author "Jack D. Unrue"
:licence "BSD"
+ :depends-on ("cells")
:components
((:module "src"
:components
Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
==============================================================================
--- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original)
+++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Apr 9 14:02:36 2006
@@ -35,10 +35,10 @@
(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80))
-(defgeneric update-buffer (disp tiles)
+(defgeneric update-buffer (disp)
(:documentation "Revises the image buffer so that the associated window can be repainted.")
- (:method (disp tiles)
- (declare (ignorable disp tiles))))
+ (:method (disp)
+ (declare (ignorable disp))))
(defclass double-buffered-event-dispatcher (gfw:event-dispatcher)
((image-buffer
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/scoreboard-panel.lisp (original)
+++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 9 14:02:36 2006
@@ -92,9 +92,10 @@
(setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*)))
(gfs:dispose gc))))
-(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value-text)
+(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value)
(let* ((metrics (gfg:metrics gc label-font))
- (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics)))))
+ (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics))))
+ (value-text (format nil "~:d" value)))
(setf (gfg:font gc) label-font)
(setf (gfg:foreground-color gc) *text-color*)
(gfg:draw-text gc label-text text-pnt)
@@ -103,8 +104,7 @@
(gfs:size-width (gfg:text-extent gc value-text))))
(gfg:draw-text gc value-text text-pnt)))
-(defmethod update-buffer ((self scoreboard-panel-events) tiles)
- (declare (ignore tiles))
+(defmethod update-buffer ((self scoreboard-panel-events))
(let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
(label-font (label-font-of self))
(value-font (value-font-of self))
@@ -112,9 +112,9 @@
(unwind-protect
(progn
(clear-buffer self gc)
- (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (model-level))
- (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (model-score))
- (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (model-points-needed)))
+ (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 2 image-size label-font +points-needed-label+ value-font (game-points-needed)))
(gfs:dispose gc))))
(defclass scoreboard-panel (gfw:panel) ())
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Apr 9 14:02:36 2006
@@ -95,7 +95,7 @@
(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button)
(declare (ignore time))
- (let* ((tiles (model-tiles))
+ (let* ((tiles (game-tiles))
(tile-pnt (window->tiles point))
(tile-kind (obtain-tile tiles tile-pnt))
(shape-pnts (shape-pnts-of self))
@@ -118,23 +118,18 @@
(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button)
(declare (ignore time))
- (let* ((tiles (model-tiles))
- (tile-pnt (window->tiles point))
- (shape-pnts (shape-pnts-of self)))
+ (let ((tile-pnt (window->tiles point))
+ (shape-pnts (shape-pnts-of self)))
(if (and (eql button :left-button)
shape-pnts
(find tile-pnt shape-pnts :test #'eql-point))
- (progn
- (loop for pnt in shape-pnts do (set-tile tiles pnt 0))
- (collapse-tiles tiles)
- (update-buffer (gfw:dispatcher panel) tiles)
- (gfw:redraw panel))
+ (game-shape-data shape-pnts)
(if shape-pnts
(draw-tiles-directly panel shape-pnts (shape-kind-of self)))))
(setf (shape-kind-of self) 0)
(setf (shape-pnts-of self) nil))
-(defmethod update-buffer ((self tiles-panel-events) tiles)
+(defmethod update-buffer ((self tiles-panel-events))
(let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
(image-table (tile-image-table-of self)))
(clear-buffer self gc)
@@ -142,7 +137,7 @@
(map-tiles #'(lambda (pnt kind)
(unless (= kind 0)
(gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
- tiles)
+ (game-tiles))
(gfs:dispose gc))))
(defclass tiles-panel (gfw:panel) ())
Modified: trunk/src/demos/unblocked/tiles.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles.lisp (original)
+++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 9 14:02:36 2006
@@ -120,3 +120,10 @@
(let ((size (size-tiles tiles)))
(dotimes (i (gfs:size-width size))
(setf (aref tiles i) (collapse-column (aref tiles i))))))
+
+(defun clone-tiles (orig-tiles)
+ (let* ((width (gfs:size-width (size-tiles orig-tiles)))
+ (new-tiles (make-array width :initial-element nil)))
+ (dotimes (i width)
+ (setf (aref new-tiles i) (copy-seq (aref orig-tiles i))))
+ new-tiles))
Modified: trunk/src/demos/unblocked/unblocked-model.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-model.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 9 14:02:36 2006
@@ -33,26 +33,79 @@
(in-package :graphic-forms.uitoolkit.tests)
-
-(defvar *tiles* nil)
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +max-tile-kinds+ 6)
- (defconstant +horz-tile-count+ 16)
+ (defconstant +horz-tile-count+ 17)
(defconstant +vert-tile-count+ 12))
-(defun init-model-tiles ()
- (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))
- *tiles*)
-
-(defun model-tiles ()
- *tiles*)
-
-(defun model-level ()
- (format nil "~:d" 134))
+(defun factorial (n)
+ (if (zerop n)
+ 1
+ (* n (factorial (1- n)))))
+
+(cells:defmodel unblocked-game-model ()
+ ((level
+ :accessor level
+ :initform (cells:c? (let* ((lvl (if cells:.cache cells:.cache 1))
+ (pnts-needed (* 20 (factorial lvl))))
+ (if (>= (^score) pnts-needed)
+ (1+ lvl)
+ lvl))))
+ (score
+ :accessor score
+ :initform (cells:c? (+ (if cells:.cache cells:.cache 0)
+ (* 5 (length (^shape-data))))))
+ (points-needed
+ :accessor points-needed
+ :initform (cells:c? (* 20 (factorial (^level)))))
+ (shape-data
+ :accessor shape-data
+ :initform (cells:c-in nil))
+ (tiles
+ :accessor tiles
+ :initform (cells:c? (let ((tmp nil)
+ (data (^shape-data)))
+ (if (null cells:.cache)
+ (progn
+ (setf tmp (init-tiles +horz-tile-count+
+ +vert-tile-count+
+ (1- +max-tile-kinds+)))
+ (collapse-tiles tmp))
+ (if data
+ (progn
+ (setf tmp (clone-tiles cells:.cache))
+ (loop for pnt in data do (set-tile tmp pnt 0))
+ (collapse-tiles tmp))
+ (setf tmp cells:.cache)))
+ tmp)))))
+
+(defvar *game* (make-instance 'unblocked-game-model))
+
+(defun reset-game ()
+ (cells:cells-reset)
+ (setf *game* (make-instance 'unblocked-game-model)))
+
+(defun game-tiles ()
+ (tiles *game*))
+
+(defun game-shape-data (pnts)
+ (setf (shape-data *game*) pnts))
+
+(defun game-level ()
+ (level *game*))
+
+(defun game-points-needed ()
+ (- (points-needed *game*) (score *game*)))
+
+(defun game-score ()
+ (score *game*))
+
+(defun update-panel (panel)
+ (update-buffer (gfw:dispatcher panel))
+ (gfw:redraw panel))
-(defun model-points-needed ()
- (format nil "~:d" 30964))
+(cells:defobserver score ((self unblocked-game-model))
+ (update-panel (get-scoreboard-panel)))
-(defun model-score ()
- (format nil "~:d" 1548238))
+(cells:defobserver tiles ((self unblocked-game-model))
+ (update-panel (get-tiles-panel)))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 9 14:02:36 2006
@@ -48,12 +48,11 @@
(defun new-unblocked (disp item time rect)
(declare (ignore disp item time rect))
+ (reset-game)
(let ((tiles-disp (gfw:dispatcher *tiles-panel*))
- (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))
- (tiles (init-model-tiles)))
- (update-buffer scoreboard-disp tiles)
- (collapse-tiles tiles)
- (update-buffer tiles-disp tiles)
+ (scoreboard-disp (gfw:dispatcher *scoreboard-panel*)))
+ (update-buffer scoreboard-disp)
+ (update-buffer tiles-disp)
(gfw:redraw *scoreboard-panel*)
(gfw:redraw *tiles-panel*)))
@@ -83,7 +82,9 @@
(:item "&Restart" :callback #'restart-unblocked)
(:item "Reveal &Move" :callback #'reveal-unblocked)
(:item "" :separator)
- (:item "E&xit" :callback #'quit-unblocked))))))
+ (:item "E&xit" :callback #'quit-unblocked)))
+ (:item "&Help"
+ :submenu ((:item "&About"))))))
(scoreboard-buffer-size (compute-scoreboard-size))
(tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+)
2)
More information about the Graphic-forms-cvs
mailing list