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)