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