[graphic-forms-cvs] r92 - trunk/src/demos/unblocked

[junrue at common-lisp.net]

Author: junrue
Date: Fri Apr  7 02:12:06 2006
New Revision: 92

Modified:
   trunk/src/demos/unblocked/tiles-panel.lisp
   trunk/src/demos/unblocked/tiles.lisp
Log:
slightly faster drawing of selected shapes

Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp	(original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp	Fri Apr  7 02:12:06 2006
@@ -39,7 +39,7 @@
 
 (defun tiles->window (pnt)
   (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+)))
-        (ypos (1+ (* (gfs:point-y pnt) +tile-bmp-height+)))
+        (ypos (1+ (* (- (1- +vert-tile-count+) (gfs:point-y pnt)) +tile-bmp-height+)))
         (size (gfw:client-size (get-tiles-panel))))
     (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size)))
       nil
@@ -109,18 +109,19 @@
         (unless (= (obtain-tile tiles tile-pnt) 0)
           (shape-tiles tiles tile-pnt results)
           (when (> (hash-table-count results) 1)
-            (maphash #'(lambda (pnt kind)
-                         (declare (ignore kind))
-                         (set-tile tiles pnt +max-tile-kinds+))
-                     results)
-            (update-buffer self tiles)
-            (gfw:redraw panel)
-            (maphash #'(lambda (pnt kind)
-                         (declare (ignore kind))
-                         (set-tile tiles pnt 0))
-                     results)
+            (let ((gc (make-instance 'gfg:graphics-context :widget panel))
+                  (image-table (tile-image-table-of self)))
+              (unwind-protect
+                  (maphash #'(lambda (pnt kind)
+                               (declare (ignore kind))
+                               (set-tile tiles pnt 0)
+                               (gfg:draw-image gc
+                                               (gethash +max-tile-kinds+ image-table)
+                                               (tiles->window pnt)))
+                           results)
+                (gfs:dispose gc)))
             (gfw:start (make-instance 'gfw:timer
-                                      :initial-delay 333
+                                      :initial-delay 100
                                       :delay 0
                                       :dispatcher (make-instance 'tiles-timer-events
                                                                  :panel-dispatcher self)))))))

Modified: trunk/src/demos/unblocked/tiles.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles.lisp	(original)
+++ trunk/src/demos/unblocked/tiles.lisp	Fri Apr  7 02:12:06 2006
@@ -51,14 +51,14 @@
   (let ((size (size-tiles tiles)))
     (dotimes (j (gfs:size-height size))
       (dotimes (i (gfs:size-width size))
-        (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j))))
+        (let ((kind (aref (aref tiles i) j)))
           (funcall func (gfs:make-point :x i :y j) kind))))))
 
 (defun print-tiles (tiles)
   (let ((size (size-tiles tiles)))
     (dotimes (j (gfs:size-height size))
       (dotimes (i (gfs:size-width size))
-        (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j))))
+        (let ((kind (aref (aref tiles i) j)))
           (if (< kind 0)
             (print "  ")
             (format t "~d " kind))))
@@ -105,8 +105,9 @@
 
 (defun collapse-column (column-tiles)
   (let ((new-column (make-array (length column-tiles) :initial-element 0))
-        (new-index 0))
-    (dotimes (i (length column-tiles))
+        (new-index 0)
+        (count (length column-tiles)))
+    (dotimes (i count)
       (let ((kind (aref column-tiles i)))
         (unless (zerop kind)
           (setf (aref new-column new-index) kind)