Author: junrue Date: Sun May 7 17:21:43 2006 New Revision: 120 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: rewrote timer such that TimerProc is no longer used; rename running-p method to enabled-p Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun May 7 17:21:43 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.3.0 +Graphic-Forms README for version 0.4.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -47,32 +47,25 @@ features in general that are not yet implemented, this section lists known problems in this release: -1. The following bug filed against CLISP 2.38 - - http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1355&atid=101355 - - may result in intermittent GPFs when windows with layout managers are - resized or when timer objects are enabled. - -2. Image loading currently requires installation of the ImageMagick +1. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows BMP files (and this is what the image-tester application displays). ImageMagick itself supports many image formats, but Graphic-Forms has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -3. The event-tester application's menu definition specifies that the +2. The event-tester application's menu definition specifies that the Test Menu | Submenu | Item A item should be disabled but it does not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -4. The src/demos/unblocked directory contains a start at a demo +3. The src/demos/unblocked directory contains a start at a demo program (a simple game where one clicks on block shapes to score points, where the rest of the blocks fall down to fill in the gaps). This demo program is not yet finished, but the source code can still serve as sample code. -5. The text-extent generic function currently does not return +4. The text-extent generic function currently does not return the correct text height. As a workaround, get the text metrics for the desired font and base height calculations on that value. The text-extent function does return the correct width. Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun May 7 17:21:43 2006 @@ -870,10 +870,6 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn -@deffn GenericFunction running-p self -Returns T if the object is in event generation mode; nil otherwise. -@end deffn - @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun May 7 17:21:43 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.3 +@c @subtitle Version 0.4 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.3) +@top Graphic-Forms Programming Reference (version 0.4) @insertcopying @end ifnottex Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun May 7 17:21:43 2006 @@ -445,7 +445,6 @@ #:retrieve-span #:right-margin-of #:run-default-message-loop - #:running-p #:scroll #:select #:select-all Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun May 7 17:21:43 2006 @@ -505,46 +505,13 @@ (by-pos BOOL) (item-info LPTR)) -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| (defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE) (id UINT) (elapse UINT) - (callback :pointer)) ;; TIMERPROC -|# - -#+lispworks -(fli:define-foreign-function - (set-timer "SetTimer") - ((hwnd :pointer) - (id :unsigned-int) - (elapse :unsigned-int) - (func :pointer)) - :result-type :unsigned-int) - -#+clisp -(ffi:def-call-out set-timer - (:name "SetTimer") - (:library "user32.dll") - (:language :stdc) - (:arguments (hwnd ffi:c-pointer) - (id ffi:uint) - (elapse ffi:uint) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (msg ffi:uint) - (id ffi:uint) - (time ffi:long)) - (:return-type nil) - (:language :stdc-stdcall)))) - (:return-type ffi:uint)) + (callback :pointer)) ;; TIMERPROC (requires _stdcall, do not use yet) ;;; SetWindowLong is deprecated in favor of SetWindowLongPtr ;;; which can be used to write code compatible to both Win32 Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 7 17:21:43 2006 @@ -407,11 +407,11 @@ 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) - (declare (ignore hwnd lparam)) + (declare (ignore lparam)) (let* ((tc (thread-context)) (timer (get-timer tc wparam))) (if (null timer) - (gfs::kill-timer (cffi:null-pointer) wparam) + (gfs::kill-timer hwnd wparam) (progn (if (<= (delay-of timer) 0) (enable timer nil) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun May 7 17:21:43 2006 @@ -45,9 +45,11 @@ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-timer-id :initform 1 :reader next-timer-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) (timers-by-id :initform (make-hash-table :test #'equal)) + (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -56,20 +58,46 @@ #+clisp (defvar *the-thread-context* nil) #+clisp (defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) *the-thread-context*) #+clisp (defun dispose-thread-context () + (let ((hwnd (utility-hwnd *the-thread-context*))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))) (setf *the-thread-context* nil)) #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) (when (null tc) (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) tc)) #+lispworks (defun dispose-thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) + +(defmethod init-utility-hwnd ((tc thread-context)) + (register-toplevel-noerasebkgnd-window-class) + (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here + "" ; because of circular dependency + (cffi:null-pointer) + (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-popup+) + 0))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value tc 'utility-hwnd) hwnd))) (defmethod call-child-visitor-func ((tc thread-context) parent child) "Call the closure at the top of the child window visitor function stack." @@ -163,3 +191,9 @@ (if (eql k (id-of timer)) (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) + +(defmethod increment-timer-id ((tc thread-context)) + "Return the next timer ID; also increment the internal value." + (let ((id (next-timer-id tc))) + (incf (slot-value tc 'next-timer-id)) + id)) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 17:21:43 2006 @@ -33,39 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -#+lispworks -(fli:define-foreign-callable - ("timer_proc" :result-type :void :calling-convention :stdcall) - ((hwnd :pointer) - (msg :unsigned-int) - (id :unsigned-int) - (time :long)) - (process-message hwnd gfs::+wm-timer+ id time)) - -#+lispworks -(defun gf-set-timer (delay) - (gfs::set-timer (cffi:null-pointer) - 0 delay - (fli:make-pointer :symbol-name "timer_proc"))) - -#+clisp -(defun timer_proc (hwnd msg id time) - (declare (ignore msg)) - (process-message hwnd gfs::+wm-timer+ id time) - nil) - -#+clisp -(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." ;; @@ -85,18 +52,23 @@ (setf delay gfs::+user-timer-maximum+)) (values init-delay delay)) -(defmethod (setf delay-of) :around (value (self timer)) - (multiple-value-bind (init-delay delay) - (clamp-delay-values 0 value) +(defun reset-timer-to-delay (timer delay) + (if (and (> (id-of timer) 0) (= (delay-of timer) delay)) + (return-from reset-timer-to-delay nil)) + (multiple-value-bind (init-delay clamped) + (clamp-delay-values 0 delay) (declare (ignore init-delay)) - (if (/= delay (slot-value self 'delay)) - (setf (slot-value self 'delay) delay) - (let ((tc (thread-context)) - (new-id (gf-set-timer delay))) - (unless (or (not (running-p self)) (= new-id (id-of self))) - (remove-timer tc self) - (put-timer tc self)) - (setf (slot-value self 'id-of) new-id))))) + (let ((tc (thread-context)) + (id (id-of timer))) + (when (zerop id) + (setf (slot-value timer 'id) (increment-timer-id tc)) + (put-timer tc timer)) + (if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer))) + (error 'gfs:win32-error :detail "set-timer failed"))) + clamped)) + +(defmethod (setf delay-of) :around (value (self timer)) + (setf (slot-value self 'delay) (reset-timer-to-delay self value))) (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) @@ -118,8 +90,8 @@ (let ((init-delay (initial-delay-of self))) (if (> init-delay 0) (reset-timer-to-delay self init-delay) - (reset-timer-to-delay self (delay-of self))))) + (setf (delay-of self) (delay-of self))))) (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick -(defmethod running-p ((self timer)) +(defmethod enabled-p ((self timer)) (get-timer (thread-context) (id-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun May 7 17:21:43 2006 @@ -279,9 +279,6 @@ (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric running-p (self) - (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) - (defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun May 7 17:21:43 2006 @@ -36,7 +36,6 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (gfg::initialize-magick (cffi:null-pointer)) - (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn) (run-default-message-loop)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun May 7 17:21:43 2006 @@ -33,8 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") -(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) ;;; ;;; helper functions