[graphic-forms-cvs] r90 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/graphics uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Apr 4 05:04:46 UTC 2006
Author: junrue
Date: Tue Apr 4 01:04:44 2006
New Revision: 90
Modified:
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/blue-tile.bmp
trunk/src/tests/uitoolkit/brown-tile.bmp
trunk/src/tests/uitoolkit/gold-tile.bmp
trunk/src/tests/uitoolkit/green-tile.bmp
trunk/src/tests/uitoolkit/image-tester.lisp
trunk/src/tests/uitoolkit/pink-tile.bmp
trunk/src/tests/uitoolkit/red-tile.bmp
trunk/src/uitoolkit/graphics/image.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/timer.lisp
Log:
fixed timer bugs; implemented collapse redraw when tile shape is selected
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Tue Apr 4 01:04:44 2006
@@ -36,17 +36,32 @@
(defconstant +tile-bmp-width+ 24)
(defconstant +tile-bmp-height+ 24)
+(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80))
+
+(defclass tiles-timer-events (gfw:event-dispatcher)
+ ((panel-dispatcher
+ :accessor panel-dispatcher
+ :initarg :panel-dispatcher
+ :initform nil)))
+
+(defmethod gfw:event-timer ((self tiles-timer-events) timer time)
+ (declare (ignore timer time))
+ (let ((tiles (model-tiles)))
+ (collapse-tiles tiles)
+ (update-buffer (panel-dispatcher self) tiles)
+ (gfw:redraw (get-tiles-panel))))
+
(defun tiles->window (pnt)
- (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+))
- (ypos (* (gfs:point-y pnt) +tile-bmp-height+))
+ (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+)))
+ (ypos (1+ (* (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
(gfs:make-point :x xpos :y ypos))))
(defun window->tiles (pnt)
- (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+)))
- (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+))))))
+ (let ((xpos (floor (/ (1- (gfs:point-x pnt)) +tile-bmp-width+)))
+ (ypos (- +vert-tile-count+ (1+ (floor (/ (1- (gfs:point-y pnt)) +tile-bmp-height+))))))
(if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+))
nil
(gfs:make-point :x xpos :y ypos))))
@@ -54,10 +69,12 @@
(defclass tiles-panel-events (gfw:event-dispatcher)
((image-buffer
:accessor image-buffer-of
- :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+
- +tile-bmp-width+)
- :height (* +vert-tile-count+
- +tile-bmp-height+))))
+ :initform (make-instance 'gfg:image :size (gfs:make-size :width (+ (* +horz-tile-count+
+ +tile-bmp-width+)
+ 2)
+ :height (+ (* +vert-tile-count+
+ +tile-bmp-height+)
+ 2))))
(tile-image-table
:accessor tile-image-table-of
:initform (make-hash-table :test #'equal))
@@ -111,22 +128,30 @@
(set-tile tiles pnt +max-tile-kinds+))
results)
(update-buffer self tiles)
- (gfw:redraw panel)))))
+ (gfw:redraw panel)
+ (maphash #'(lambda (pnt kind)
+ (declare (ignore kind))
+ (set-tile tiles pnt 0))
+ results)
+ (gfw:start (make-instance 'gfw:timer
+ :initial-delay 333
+ :delay 0
+ :dispatcher (make-instance 'tiles-timer-events
+ :panel-dispatcher self)))))))
(setf (mouse-tile-of self) nil)))
(defmethod update-buffer ((self tiles-panel-events) tiles)
- (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
- (image-table (tile-image-table-of self))
- (pixel-pnt (gfs:make-point)))
- (setf (gfg:background-color gc) gfg:*color-black*)
- (setf (gfg:foreground-color gc) gfg:*color-black*)
+ (let* ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
+ (image-table (tile-image-table-of self))
+ (image (image-buffer-of self))
+ (size (gfg:size image)))
+ (setf (gfg:background-color gc) *background-color*)
+ (setf (gfg:foreground-color gc) *background-color*)
(gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point)
- :size (gfg:size (image-buffer-of self))))
+ :size size))
(map-tiles #'(lambda (pnt kind)
(unless (= kind 0)
- (let ((image (gethash kind image-table)))
- (gfg:with-transparency (image pixel-pnt)
- (gfg:draw-image gc image (tiles->window pnt))))))
+ (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
tiles)
(gfs:dispose gc)))
@@ -138,4 +163,5 @@
(defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint)
(declare (ignore width-hint height-hint))
- (gfg:size (image-buffer-of (gfw:dispatcher self))))
+ (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self)))))
+ (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2))))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Tue Apr 4 01:04:44 2006
@@ -93,6 +93,7 @@
:dispatcher (make-instance 'scoreboard-panel-events)))
(setf *tiles-panel* (make-instance 'tiles-panel
:parent *unblocked-win*
+ :style '(:border)
:dispatcher (make-instance 'tiles-panel-events)))
(setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked")
(gfw:pack *unblocked-win*)
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Apr 4 01:04:44 2006
@@ -197,7 +197,7 @@
#:transparency
#:transparency-pixel-of
#:transparency-mask
- #:with-transparency
+ #:with-image-transparency
#:xor-mode-p
;; conditions
Modified: trunk/src/tests/uitoolkit/blue-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/brown-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/gold-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/green-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp Tue Apr 4 01:04:44 2006
@@ -63,7 +63,7 @@
(gfg:draw-image gc *happy-image* pnt)
(incf (gfs:point-x pnt) 36)
- (gfg:with-transparency (*happy-image* pixel-pnt1)
+ (gfg:with-image-transparency (*happy-image* pixel-pnt1)
(gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt)
(incf (gfs:point-x pnt) 36)
(gfg:draw-image gc *happy-image* pnt))
@@ -72,7 +72,7 @@
(incf (gfs:point-y pnt) 36)
(gfg:draw-image gc *bw-image* pnt)
(incf (gfs:point-x pnt) 24)
- (gfg:with-transparency (*bw-image* pixel-pnt1)
+ (gfg:with-image-transparency (*bw-image* pixel-pnt1)
(gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt)
(incf (gfs:point-x pnt) 24)
(gfg:draw-image gc *bw-image* pnt))
@@ -81,7 +81,7 @@
(incf (gfs:point-y pnt) 20)
(gfg:draw-image gc *true-image* pnt)
(incf (gfs:point-x pnt) 20)
- (gfg:with-transparency (*true-image* pixel-pnt2)
+ (gfg:with-image-transparency (*true-image* pixel-pnt2)
(gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt)
(incf (gfs:point-x pnt) 20)
(gfg:draw-image gc *true-image* pnt))))
Modified: trunk/src/tests/uitoolkit/pink-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/red-tile.bmp
==============================================================================
Binary files. No diff available.
Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp (original)
+++ trunk/src/uitoolkit/graphics/image.lisp Tue Apr 4 01:04:44 2006
@@ -37,7 +37,7 @@
;;; helper macros and functions
;;;
-(defmacro with-transparency ((image pnt) &body body)
+(defmacro with-image-transparency ((image pnt) &body body)
(let ((orig-pnt (gensym)))
`(let ((,orig-pnt (transparency-pixel-of ,image)))
(unwind-protect
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 4 01:04:44 2006
@@ -347,9 +347,10 @@
(if (null timer)
(gfs::kill-timer (cffi:null-pointer) wparam)
(progn
- (event-timer (dispatcher timer) timer (event-time tc))
- (when (<= (delay-of timer) 0)
- (stop timer)))))
+ (if (<= (delay-of timer) 0)
+ (stop timer)
+ (reset-timer-to-delay timer (delay-of timer)))
+ (event-timer (dispatcher timer) timer (event-time tc)))))
0)
;;;
Modified: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/timer.lisp (original)
+++ trunk/src/uitoolkit/widgets/timer.lisp Tue Apr 4 01:04:44 2006
@@ -58,6 +58,14 @@
(defun gf-set-timer (delay)
(gfs::set-timer nil 0 delay #'timer_proc))
+(defun reset-timer-to-delay (timer delay)
+ (remove-timer (thread-context) timer)
+ (let ((id (gf-set-timer delay)))
+ (if (zerop id)
+ (error 'gfs:win32-error :detail "set-timer failed"))
+ (setf (slot-value timer 'id) id)
+ (put-timer (thread-context) timer)))
+
(defun clamp-delay-values (init-delay delay)
"Adjust delay settings based on system-defined limits."
;;
@@ -105,15 +113,10 @@
;; tick; the interval will be adjusted (or the timer killed)
;; as part of processing the first event
;;
- (let ((init-delay (initial-delay-of self))
- (delay (delay-of self)))
+ (let ((init-delay (initial-delay-of self)))
(if (> init-delay 0)
- (setf delay init-delay))
- (let ((id (gf-set-timer delay)))
- (if (zerop id)
- (error 'gfs:win32-error :detail "set-timer failed"))
- (setf (slot-value self 'id) id)
- (put-timer (thread-context) self))))
+ (reset-timer-to-delay self init-delay)
+ (reset-timer-to-delay self (delay-of self)))))
(defmethod stop ((self timer))
(remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick
More information about the Graphic-forms-cvs
mailing list