From junrue at common-lisp.net Tue May 2 05:02:28 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 2 May 2006 01:02:28 -0400 (EDT) Subject: [graphic-forms-cvs] r115 - trunk/src/uitoolkit/widgets Message-ID: <20060502050228.0084E6F23C@common-lisp.net> Author: junrue Date: Tue May 2 01:02:27 2006 New Revision: 115 Modified: trunk/src/uitoolkit/widgets/layout.lisp Log: corrected a compiler warning issued by LispWorks Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue May 2 01:02:27 2006 @@ -33,10 +33,11 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ - gfs::+swp-noownerzorder+ - gfs::+swp-noactivate+ - gfs::+swp-nocopybits+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+))) ;;; ;;; methods From junrue at common-lisp.net Wed May 3 22:01:17 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 3 May 2006 18:01:17 -0400 (EDT) Subject: [graphic-forms-cvs] r116 - trunk/src/uitoolkit/widgets Message-ID: <20060503220117.EEB8B5C120@common-lisp.net> Author: junrue Date: Wed May 3 18:01:17 2006 New Revision: 116 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: hopefully this is the last time I have to fiddle with key event processing Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed May 3 18:01:17 2006 @@ -215,7 +215,7 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when w + (when (and w (zerop ch)) (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) From junrue at common-lisp.net Thu May 4 20:22:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 4 May 2006 16:22:48 -0400 (EDT) Subject: [graphic-forms-cvs] r117 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060504202248.78C8F4610C@common-lisp.net> Author: junrue Date: Thu May 4 16:22:47 2006 New Revision: 117 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented background-color/foreground-color/font customization for labels, infrastructure is in place for other controls too Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 4 16:22:47 2006 @@ -59,6 +59,9 @@ ;; constants ;; methods, functions, macros + #:copy-point + #:copy-size + #:copy-span #:detail #:dispose #:disposed-p @@ -98,6 +101,7 @@ (:export ;; classes and structs + #:color #:font #:font-data #:font-metrics @@ -132,6 +136,9 @@ #:color-red #:color-table #:copy-area + #:copy-color + #:copy-font-data + #:copy-font-metrics #:data-obj #:depth #:descent Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu May 4 16:22:47 2006 @@ -104,6 +104,7 @@ ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here + (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*)) (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) (gfg:with-image-transparency (tmp-image (gfs:make-point)) (setf (gfw:image w) tmp-image)))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu May 4 16:22:47 2006 @@ -152,6 +152,11 @@ (path :string)) (defcfun + ("CreateSolidBrush" create-solid-brush) + HANDLE + (color COLORREF)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu May 4 16:22:47 2006 @@ -800,6 +800,13 @@ (defconstant +wm-initmenupopup+ #x0117) (defconstant +wm-menuselect+ #x011F) (defconstant +wm-menuchar+ #x0120) +(defconstant +wm-ctlcolormsgbox+ #x0132) +(defconstant +wm-ctlcoloredit+ #x0133) +(defconstant +wm-ctlcolorlistbox+ #x0134) +(defconstant +wm-ctlcolorbtn+ #x0135) +(defconstant +wm-ctlcolordlg+ #x0136) +(defconstant +wm-ctlcolorscrollbar+ #x0137) +(defconstant +wm-ctlcolorstatic+ #x0138) (defconstant +wm-mousefirst+ #x0200) ; for use with peek-message (defconstant +wm-mousemove+ #x0200) (defconstant +wm-lbuttondown+ #x0201) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 4 16:22:47 2006 @@ -259,6 +259,13 @@ (index INT)) (defcfun + ("GetClassNameA" get-class-name) + INT + (hwnd HANDLE) + (classname LPTSTR) + (maxcount INT)) + +(defcfun ("GetClientRect" get-client-rect) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu May 4 16:22:47 2006 @@ -53,13 +53,40 @@ ;;; methods ;;; -(defmethod background-color :before ((ctrl control)) +(defmethod gfg:background-color :before ((ctrl control)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) -(defmethod background-color ((ctrl control)) - (declare (ignore ctrl)) - (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) +(defmethod gfg:background-color ((ctrl control)) + (or (brush-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + +(defmethod (setf gfg:background-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:background-color) (color (ctrl control)) + (let ((hbrush (brush-handle-of ctrl))) + (when (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (setf hbrush (gfs::create-solid-brush (gfg:color->rgb color))) + (if (gfs:null-handle-p hbrush) + (error 'gfs:win32-error :detail "create-solid-brush failed")) + (setf (brush-color-of ctrl) (gfg:copy-color color)) + (setf (brush-handle-of ctrl) hbrush)) + (redraw ctrl)) + +(defmethod gfs:dispose ((ctrl control)) + (let ((hbrush (brush-handle-of ctrl)) + (font (font-of ctrl))) + (if font + (gfs:dispose font)) + (setf (font-of ctrl) nil) + (if (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush)) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (call-next-method)) (defmethod focus-p :before ((ctrl control)) (if (gfs:disposed-p ctrl) @@ -69,6 +96,38 @@ (let ((focus-hwnd (gfs::get-focus))) (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl))))) +(defmethod gfg:font :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:font ((ctrl control)) + (font-of ctrl)) + +(defmethod (setf gfg:font) :before (font (ctrl control)) + (declare (ignore color)) + (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font)) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:font) (font (ctrl control)) + (setf (font-of ctrl) font) + (redraw ctrl)) + +(defmethod gfg:foreground-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:foreground-color ((ctrl control)) + (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+)))) + +(defmethod (setf gfg:foreground-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:foreground-color) (color (ctrl control)) + (setf (text-color-of ctrl) (gfg:copy-color color)) + (redraw ctrl)) + (defmethod give-focus :before ((ctrl control)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 4 16:22:47 2006 @@ -306,6 +306,27 @@ (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) +(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) + (declare (ignore hwnd)) + (let* ((tc (thread-context)) + (widget (get-widget tc (cffi:make-pointer lparam))) + (hdc (cffi:make-pointer wparam)) + (bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget)) + (ret-val 0)) + (when widget + (if (not (typep widget 'label)) + (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC")) + (let ((font (font-of widget))) + (if font + (gfs::select-object hdc (gfs:handle font)))) + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) + ret-val)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu May 4 16:22:47 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; (defun compute-image-style-flags (style) @@ -77,6 +77,20 @@ (setf flags (logior flags gfs::+ss-left+))))) flags)) +;;; +;;; methods +;;; + +(defmethod (setf gfg:background-color) (color (label label)) + (declare (ignorable color)) + (call-next-method) + (let ((image (image label)) + (pnt (pixel-point-of label))) + (when image + (if pnt + (setf (gfg:transparency-pixel-of image) pnt)) + (setf (image label) image)))) + (defmethod compute-style-flags ((label label) style &rest extra-data) (declare (ignore label)) (if (> (count-if-not #'null extra-data) 1) @@ -113,7 +127,7 @@ gfs::+ws-visible+)) (tr-pnt (gfg:transparency-pixel-of image))) (if tr-pnt - (let* ((color (background-color label)) + (let* ((color (gfg:background-color label)) (size (gfg:size image)) (bounds (make-instance 'gfs:rectangle :size size)) (tmp-image (make-instance 'gfg:image :size size)) @@ -125,7 +139,8 @@ (setf (gfg:foreground-color gc) color) (gfg:draw-filled-rectangle gc bounds) (setf (gfg:foreground-color gc) orig-color)) - (gfg:draw-image gc image (gfs:location bounds))) + (gfg:draw-image gc image (gfs:location bounds)) + (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (gfs:dispose gc)) (setf image tmp-image))) (if (/= orig-flags flags) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 4 16:22:47 2006 @@ -33,9 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") -(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") - (defconstant +default-window-title+ "New Window") ;;; Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 4 16:22:47 2006 @@ -65,7 +65,22 @@ (defclass caret (widget) () (:documentation "The caret class provides an i-beam typically representing an insertion point.")) -(defclass control (widget) () +(defclass control (widget) + ((brush-color + :accessor brush-color-of + :initform nil) + (brush-handle + :accessor brush-handle-of + :initform (cffi:null-pointer)) + (font + :accessor font-of + :initform nil) + (text-color + :accessor text-color-of + :initform nil) + (pixel-point + :accessor pixel-point-of + :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) (defclass button (control) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 16:22:47 2006 @@ -51,9 +51,6 @@ (defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) -(defgeneric background-color (self) - (:documentation "Returns a color object corresponding to the current background color.")) - (defgeneric border-width (self) (:documentation "Returns the object's border width.")) @@ -156,9 +153,6 @@ (defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise.")) -(defgeneric foreground-color (self) - (:documentation "Returns a color object corresponding to the current foreground color.")) - (defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu May 4 16:22:47 2006 @@ -33,6 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") +(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") + ;;; ;;; helper functions ;;; @@ -151,8 +154,15 @@ ;;; methods ;;; -(defmethod background-color ((win window)) - (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) +(defmethod gfg:background-color ((win window)) + (let ((hwnd (gfs:handle win)) + (color nil)) + (cffi:with-foreign-pointer-as-string (str-ptr 64) + (gfs::get-class-name hwnd str-ptr 64) + (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) + (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) + color)) (defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect From junrue at common-lisp.net Fri May 5 01:08:49 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 4 May 2006 21:08:49 -0400 (EDT) Subject: [graphic-forms-cvs] r118 - in trunk: docs/manual src src/uitoolkit/widgets Message-ID: <20060505010849.211747D001@common-lisp.net> Author: junrue Date: Thu May 4 21:08:48 2006 New Revision: 118 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented append-separator method for programmatically adding separators to menus Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 4 21:08:48 2006 @@ -668,6 +668,11 @@ the newly-created item. @end deffn + at deffn GenericFunction append-separator self +Adds a separator item to the object, and returns the newly-created +item. + at end deffn + @deffn GenericFunction append-submenu self text submenu dispatcher Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 4 21:08:48 2006 @@ -310,6 +310,7 @@ #:alignment #:ancestor-p #:append-item + #:append-separator #:append-submenu #:background-color #:background-pattern Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Thu May 4 21:08:48 2006 @@ -202,13 +202,8 @@ (check item checked))) (defmethod define-separator ((gen win32-menu-generator)) - (let* ((owner (first (menu-stack-of gen))) - (it (make-instance 'menu-item)) - (hmenu (gfs:handle owner))) - (put-menuitem (thread-context) it) - (insert-separator hmenu) - (setf (slot-value it 'gfs:handle) hmenu) - (vector-push-extend it (items owner)))) + (let ((owner (first (menu-stack-of gen)))) + (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu May 4 21:08:48 2006 @@ -87,7 +87,7 @@ (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed"))))) -(defun insert-separator (hmenu) +(defun insert-separator (hmenu mid) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type gfs::state gfs::id gfs::hsubmenu @@ -96,10 +96,10 @@ gfs::hbmpitem) mii-ptr gfs::menuiteminfo) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask gfs::+miim-ftype+) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+)) (setf gfs::type gfs::+mft-separator+) (setf gfs::state 0) - (setf gfs::id 0) + (setf gfs::id mid) (setf gfs::hsubmenu (cffi:null-pointer)) (setf gfs::hbmpchecked (cffi:null-pointer)) (setf gfs::hbmpunchecked (cffi:null-pointer)) @@ -142,6 +142,19 @@ (vector-push-extend item (items owner)) item)) +(defmethod append-separator ((owner menu)) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let* ((tc (thread-context)) + (id (increment-menuitem-id tc)) + (howner (gfs:handle owner)) + (item (make-instance 'menu-item :handle howner))) + (insert-separator howner id) + (setf (item-id item) id) + (put-menuitem tc item) + (vector-push-extend item (items owner)) + item)) + (defmethod append-submenu ((parent menu) text (submenu menu) disp) (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 21:08:48 2006 @@ -48,6 +48,9 @@ (defgeneric append-item (self text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) +(defgeneric append-separator (self) + (:documentation "Add a separator item to the object, and returns the newly-created item.")) + (defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) From junrue at common-lisp.net Sat May 6 22:59:15 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 6 May 2006 18:59:15 -0400 (EDT) Subject: [graphic-forms-cvs] r119 - trunk/src/demos/unblocked Message-ID: <20060506225915.E93BD21002@common-lisp.net> Author: junrue Date: Sat May 6 18:59:15 2006 New Revision: 119 Modified: trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp Log: minor cleanup and refactoring of unblocked game model Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sat May 6 18:59:15 2006 @@ -119,7 +119,8 @@ (defun collapse-tiles (tiles) (let ((size (size-tiles tiles))) (dotimes (i (gfs:size-width size)) - (setf (aref tiles i) (collapse-column (aref tiles i)))))) + (setf (aref tiles i) (collapse-column (aref tiles i))))) + tiles) (defun clone-tiles (orig-tiles) (let* ((width (gfs:size-width (size-tiles orig-tiles))) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sat May 6 18:59:15 2006 @@ -36,48 +36,44 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-tile-kinds+ 6) (defconstant +horz-tile-count+ 17) - (defconstant +vert-tile-count+ 12)) + (defconstant +vert-tile-count+ 12) + (defconstant +max-levels+ 21)) -(defun factorial (n) - (if (zerop n) - 1 - (* n (factorial (1- n))))) +(defvar *points-needed-table* (loop for level from 1 to +max-levels+ + collect (* 250 level level))) + +(defun lookup-level-reached (score) + (let ((level 1)) + (loop for entry in *points-needed-table* + until (> entry score) + do (incf level)) + level)) (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)))) + :initform (cells:c? (lookup-level-reached (^score)))) (score :accessor score - :initform (cells:c? (+ (if cells:.cache cells:.cache 0) + :initform (cells:c? (+ (or 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))))) + :initform (cells:c? (let ((data (^shape-data))) + (cond + ((null cells:.cache) + (collapse-tiles (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+)))) + (data + (let ((tmp (clone-tiles cells:.cache))) + (loop for pnt in data do (set-tile tmp pnt 0)) + (collapse-tiles tmp))) + (t + cells:.cache))))))) (defvar *game* (make-instance 'unblocked-game-model)) @@ -95,7 +91,7 @@ (level *game*)) (defun game-points-needed () - (- (points-needed *game*) (score *game*))) + (- (nth (1- (level *game*)) *points-needed-table*) (score *game*))) (defun game-score () (score *game*)) From junrue at common-lisp.net Sun May 7 21:21:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 7 May 2006 17:21:44 -0400 (EDT) Subject: [graphic-forms-cvs] r120 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060507212144.A8D6724003@common-lisp.net> 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 - at deffn GenericFunction running-p self -Returns T if the object is in event generation mode; nil otherwise. - at 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 - at c @subtitle Version 0.3 + at c @subtitle Version 0.4 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top - at top Graphic-Forms Programming Reference (version 0.3) + at 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 From junrue at common-lisp.net Sun May 7 22:39:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 7 May 2006 18:39:06 -0400 (EDT) Subject: [graphic-forms-cvs] r121 - trunk/src/uitoolkit/widgets Message-ID: <20060507223906.F1EF25613A@common-lisp.net> Author: junrue Date: Sun May 7 18:39:06 2006 New Revision: 121 Modified: trunk/src/uitoolkit/widgets/timer.lisp Log: make gfs:dispose a synonym for gfw:enable nil for timers Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 18:39:06 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) +;;; +;;; helper functions +;;; + (defun clamp-delay-values (init-delay delay) "Adjust delay settings based on system-defined limits." ;; @@ -67,9 +71,16 @@ (error 'gfs:win32-error :detail "set-timer failed"))) clamped)) +;;; +;;; methods +;;; + (defmethod (setf delay-of) :around (value (self timer)) (setf (slot-value self 'delay) (reset-timer-to-delay self value))) +(defmethod gfs:dispose ((self timer)) + (enable self nil)) + (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) (error 'gfs:toolkit-error :detail ":delay value required")) From junrue at common-lisp.net Sun May 7 23:30:01 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 7 May 2006 19:30:01 -0400 (EDT) Subject: [graphic-forms-cvs] r122 - trunk/src/uitoolkit/widgets Message-ID: <20060507233001.56B07200B@common-lisp.net> Author: junrue Date: Sun May 7 19:30:01 2006 New Revision: 122 Modified: trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/timer.lisp Log: timer initial-delay bug fix Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 7 19:30:01 2006 @@ -412,11 +412,17 @@ (timer (get-timer tc wparam))) (if (null timer) (gfs::kill-timer hwnd wparam) - (progn - (if (<= (delay-of timer) 0) - (enable timer nil) - (reset-timer-to-delay timer (delay-of timer))) - (event-timer (dispatcher timer) timer (event-time tc))))) + (cond + ((<= (delay-of timer) 0) + (event-timer (dispatcher timer) timer (event-time tc)) + (gfs:dispose timer)) + ((/= (delay-of timer) (initial-delay-of timer)) + (let ((delay (reset-timer-to-delay timer (delay-of timer)))) + (setf (slot-value timer 'delay) delay) + (setf (slot-value timer 'initial-delay) delay)) + (event-timer (dispatcher timer) timer (event-time tc))) + (t + (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 Sun May 7 19:30:01 2006 @@ -57,8 +57,6 @@ (values init-delay delay)) (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)) @@ -79,7 +77,9 @@ (setf (slot-value self 'delay) (reset-timer-to-delay self value))) (defmethod gfs:dispose ((self timer)) - (enable self nil)) + (let ((tc (thread-context))) + (remove-timer tc self) + (gfs::kill-timer (utility-hwnd tc) (id-of self)))) (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) @@ -102,7 +102,7 @@ (if (> init-delay 0) (reset-timer-to-delay self init-delay) (setf (delay-of self) (delay-of self))))) - (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick + (gfs:dispose self))) (defmethod enabled-p ((self timer)) (get-timer (thread-context) (id-of self))) From junrue at common-lisp.net Wed May 10 19:41:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 10 May 2006 15:41:31 -0400 (EDT) Subject: [graphic-forms-cvs] r123 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060510194131.691D750006@common-lisp.net> Author: junrue Date: Wed May 10 15:41:30 2006 New Revision: 123 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial steps towards support for user-defined dialogs; refactored file-dialog and updated docs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed May 10 15:41:30 2006 @@ -191,7 +191,8 @@ This is the base class for system and user-defined dialogs. A dialog is a windowed UI component that is @emph{typically} defined to remain on top of the primary application window(s). Of course, some -applications are entirely dialog-based. +applications are entirely dialog-based. This class derives from + at ref{window}. @end deftp @anchor{display} @@ -236,7 +237,7 @@ @end deftp @anchor{file-dialog} - at deftp Class file-dialog + at deftp Class file-dialog open-mode This class provides a standard @ref{dialog} for navigating the file system to select or enter file names. A variety of configurations are possible; however, please note that the following behaviors are @@ -245,11 +246,15 @@ @item in @code{:save} mode, the user will be prompted to confirm overwrite when an existing file is selected @end itemize -Applications retrieve selected files by calling the @code{items} -function, which returns a @sc{vector} of @sc{file namestring}s, one -for each selection. Unless the @code{:multiple-select} style keyword -is specified, there will at most be one selected file returned, and -possibly zero if the user cancelled the dialog.@*@* +The @ref{with-file-dialog} macro wraps the creation of a + at code{file-dialog} and subsequent retrieval of the file paths selected +by the user. However, applications may choose to implements these +steps manually, in which case the @ref{file-dialog-paths} function can +be used to obtain the user's selection(s). Unless the + at code{:multiple-select} style keyword is specified, there will at most +be one selected file returned, and possibly zero if the user cancelled +the dialog. Also, manual construction of an instance must be followed +by an explicit call to @ref{dispose}.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if the user fails to provide one. Any embedded periods @samp{.} will @@ -743,6 +748,14 @@ Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. @end deffn + at anchor{file-dialog-paths} + at deffn Function file-dialog-paths dlg +Interrogates the data structure associated with an instance of + at ref{file-dialog} to obtain the paths for selected files. This return +value is either @sc{nil} if the user cancelled the dialog, or a list +of file @sc{namestring}s. + at end deffn + @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} otherwise. @@ -870,6 +883,7 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn + at anchor{show} @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. @@ -901,6 +915,13 @@ @end deffn @end html + at anchor{with-file-dialog} + at deffn Macro with-file-dialog (owner style paths &key default extension filters initial-directory initial-filename text) &body body +This macro wraps the instantiation of a standard file open/save dialog +and the subsequent retrieval of the user's file +selections. @xref{file-dialog}. + at end deffn + @node layout functions @section layout functions Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed May 10 15:41:30 2006 @@ -385,6 +385,7 @@ #:event-timer #:expand #:expanded-p + #:file-dialog-paths #:focus-index #:focus-p #:foreground-color @@ -482,6 +483,7 @@ #:visible-item-count #:visible-p #:with-children + #:with-file-dialog ;; conditions )) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 15:41:30 2006 @@ -98,24 +98,36 @@ (defun open-file-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* - :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") - ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") - ("All Files (*.*)" . "*.*")) - :initial-directory #P"c:/" - :style '(:add-to-recent :multiple-select :open) - :text "Select Lisp-related files..."))) - (print (gfw:items dlg)))) + (gfw:with-file-dialog (*main-win* + '(:open :add-to-recent :multiple-select) + paths + :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") + ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :text "Select Lisp-related files...") + (print paths))) (defun save-file-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* - :default-extension "dat" - :filters '(("Data files (*.dat)" . "*.dat") - ("All Files (*.*)" . "*.*")) - :initial-directory #P"c:/" - :style '(:save)))) - (print (gfw:items dlg)))) + (gfw:with-file-dialog (*main-win* + '(:save) + paths + :filters '(("Data files (*.dat)" . "*.dat") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/") + (print paths))) + +(defun open-modal-dlg (disp item time rect) + (declare (ignore disp item time rect))) +#| + (let ((dlg (make-instance 'gfw:dialog :owner *main-win* + :style '(:modal)))) + (gfw:show dlg t))) +|# + +(defun open-modeless-dlg (disp item time rect) + (declare (ignore disp item time rect))) (defun run-windlg-internal () (let ((menubar nil)) @@ -123,13 +135,16 @@ :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) - (:item "&Dialogs" + (:item "&System Dialogs" :submenu ((:item "&Open File" :callback #'open-file-dlg) (:item "&Save File" :callback #'save-file-dlg))) + (:item "&User Dialogs" + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Wed May 10 15:41:30 2006 @@ -218,17 +218,17 @@ (ofnfilterindex DWORD) (ofnfile LPTR) (ofnmaxfile DWORD) - (ofnfiletitle :string) + (ofnfiletitle :pointer) (ofnmaxfiletitle DWORD) - (ofninitialdir :string) - (ofntitle :string) + (ofninitialdir :pointer) + (ofntitle :pointer) (ofnflags DWORD) (ofnfileoffset WORD) (ofnfileext WORD) - (ofndefext :string) + (ofndefext :pointer) (ofncustdata LPARAM) (ofnhookfn LPTR) - (ofntemplname :string) + (ofntemplname :pointer) (ofnpvreserved LPTR) (ofndwreserved DWORD) (ofnexflags DWORD)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed May 10 15:41:30 2006 @@ -34,27 +34,20 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; -(defmethod focus-p :before ((dlg dialog)) - (if (gfs:disposed-p dlg) - (error 'gfs:disposed-error))) - -(defmethod focus-p ((dlg dialog)) - (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle dlg))))) - -(defmethod give-focus :before ((dlg dialog)) - (if (gfs:disposed-p dlg) - (error 'gfs:disposed-error))) +#| +(defun register-user-dialog-class () + (register-window-class +user-dialog-classname+ + (cffi:get-callback 'uit_dialog_wndproc) + (logior gfs::+cs-dblclks+ + gfs::+cs-savebits+ + gfs::+cs-bytealignwindow+) + gfs::+color-btnface+)) +|# -(defmethod give-focus ((dlg dialog)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle dlg))) - (error 'gfs:toolkit-error "set-focus failed"))) +;;; +;;; methods +;;; -(defmethod print-object ((self dialog) stream) - (print-unreadable-object (self stream :type t) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Wed May 10 15:41:30 2006 @@ -37,6 +37,39 @@ ;;; helper functions ;;; +(defun file-dialog-paths (dlg) + (let ((paths nil) + (ofn-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p ofn-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) + (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) + (dir-str (first raw-list))) + (if (cdr raw-list) + (setf paths (loop for filename in (cdr raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) + (setf paths (list (parse-namestring dir-str))))))) + paths)) + +(defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) + (let ((dlg (gensym))) + `(let ((,paths nil) + (,dlg (make-instance 'file-dialog + :default-extension ,default-extension + :filters ,filters + :initial-directory ,initial-directory + :initial-filename ,initial-filename + :owner ,owner + :style ,style + :text ,text))) + (unwind-protect + (progn + (show ,dlg t) + (setf ,paths (file-dialog-paths ,dlg)) + , at body) + (gfs:dispose ,dlg))))) + ;;; ;;; methods ;;; @@ -58,6 +91,23 @@ (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+))))) (values std-flags 0))) +(defmethod gfs:dispose ((dlg file-dialog)) + (let ((ofn-ptr (gfs:handle dlg))) + (unless (cffi:null-pointer-p ofn-ptr) + (cffi:with-foreign-slots ((gfs::ofnfile gfs::ofnfilter gfs::ofntitle + gfs::ofninitialdir gfs::ofndefext) + ofn-ptr gfs::openfilename) + (cffi:foreign-free gfs::ofnfile) + (cffi:foreign-free gfs::ofnfilter) + (unless (cffi:null-pointer-p gfs::ofntitle) + (cffi:foreign-free gfs::ofntitle)) + (unless (cffi:null-pointer-p gfs::ofninitialdir) + (cffi:foreign-free gfs::ofninitialdir)) + (unless (cffi:null-pointer-p gfs::ofndefext) + (cffi:foreign-free gfs::ofndefext))) + (cffi:foreign-free ofn-ptr) + (setf (slot-value dlg 'gfs:handle) (cffi:null-pointer))))) + (defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE ;; so that the file buffer can be resized as needed for @@ -67,7 +117,7 @@ (error 'gfs:toolkit-error :detail ":owner initarg is required")) (if (gfs:disposed-p owner) (error 'gfs:disposed-error)) - (let ((struct-ptr (cffi:foreign-alloc 'gfs::openfilename)) + (let ((ofn-ptr (cffi:foreign-alloc 'gfs::openfilename)) (filters-buffer (if filters (collect-foreign-strings (loop for entry in filters append (list (car entry) (cdr entry)))) @@ -81,8 +131,7 @@ (if initial-directory (setf dir-buffer (collect-foreign-strings (list initial-directory)))) (if default-extension - (progn - (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension)))))) + (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension))))) (if initial-filename (cffi:with-foreign-string (tmp-str (namestring initial-filename)) (gfs::strncpy file-buffer tmp-str 1023)) @@ -95,7 +144,7 @@ gfs::ofninitialdir gfs::ofntitle gfs::ofnflags gfs::ofnfileoffset gfs::ofnfileext gfs::ofndefext gfs::ofncustdata gfs::ofnhookfn gfs::ofntemplname gfs::ofnpvreserved gfs::ofndwreserved gfs::ofnexflags) - struct-ptr gfs::openfilename) + ofn-ptr gfs::openfilename) (setf gfs::ofnsize (cffi:foreign-type-size 'gfs::openfilename) gfs::ofnhwnd (gfs:handle owner) gfs::ofnhinst (cffi:null-pointer) @@ -119,23 +168,12 @@ gfs::ofnpvreserved (cffi:null-pointer) gfs::ofndwreserved 0 gfs::ofnexflags ex-style))) - (unwind-protect - (let ((fn (if (find :save style) #'gfs::get-save-filename #'gfs::get-open-filename))) - (if (and (zerop (funcall fn struct-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) - (error 'gfs:comdlg-error :detail "file dialog function failed")) - (unless (or (cffi:null-pointer-p file-buffer) (= (cffi:mem-ref file-buffer :char) 0)) - (let* ((raw-list (extract-foreign-strings file-buffer)) - (dir-str (first raw-list))) - (if (cdr raw-list) - (setf (items dlg) (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf (items dlg) (list (parse-namestring dir-str))))))) - (cffi:foreign-free file-buffer) - (cffi:foreign-free filters-buffer) - (unless (cffi:null-pointer-p title-buffer) - (cffi:foreign-free title-buffer)) - (unless (cffi:null-pointer-p dir-buffer) - (cffi:foreign-free dir-buffer)) - (unless (cffi:null-pointer-p ext-buffer) - (cffi:foreign-free ext-buffer)) - (cffi:foreign-free struct-ptr)))) + (setf (slot-value dlg 'gfs:handle) ofn-ptr) + (setf (slot-value dlg 'open-mode) (find :open style)))) + +(defmethod show ((dlg file-dialog) flag) + (declare (ignore flag)) + (let ((ofn-ptr (gfs:handle dlg)) + (fn (if (open-mode dlg) #'gfs::get-open-filename #'gfs::get-save-filename))) + (if (and (zerop (funcall fn ofn-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) + (error 'gfs:comdlg-error :detail "file dialog function failed")))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed May 10 15:41:30 2006 @@ -96,12 +96,6 @@ :initform (make-array 7 :fill-pointer 0 :adjustable t))) (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) -(defclass dialog (widget-with-items) () - (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) - -(defclass file-dialog (dialog) () - (:documentation "This class represents the standard file open/save dialog.")) - (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) @@ -115,6 +109,15 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) +(defclass dialog (window) () + (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) + +(defclass file-dialog (dialog) + ((open-mode + :reader open-mode + :initform t)) + (:documentation "This class represents the standard file open/save dialog.")) + (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 15:41:30 2006 @@ -35,7 +35,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") + (defconstant +user-dialog-classname+ "GraphicFormsUserDialog")) ;;; ;;; helper functions @@ -102,7 +103,7 @@ (pop-child-visitor-func tc))) nil) -(defun register-window-class (class-name proc-ptr style bkgcolor) +(defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -120,7 +121,7 @@ (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) - (setf gfs::wndextra 0) + (setf gfs::wndextra (or wndextra 0)) (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer))) (setf gfs::hicon (cffi:null-pointer)) (setf gfs::hcursor (gfs::load-image (cffi:null-pointer) From junrue at common-lisp.net Thu May 11 01:21:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 10 May 2006 21:21:50 -0400 (EDT) Subject: [graphic-forms-cvs] r124 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060511012150.A46497A008@common-lisp.net> Author: junrue Date: Wed May 10 21:21:49 2006 New Revision: 124 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: more work towards user-defined dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed May 10 21:21:49 2006 @@ -188,9 +188,9 @@ @anchor{dialog} @deftp Class dialog -This is the base class for system and user-defined dialogs. A dialog -is a windowed UI component that is @emph{typically} defined to remain -on top of the primary application window(s). Of course, some +This is the base class for system and application-defined dialogs. A +dialog is a windowed UI component that is @emph{typically} defined to +remain on top of the primary application window(s). Of course, some applications are entirely dialog-based. This class derives from @ref{window}. @end deftp @@ -261,8 +261,8 @@ be removed. Also, only the first three characters are used. @end deffn @deffn Initarg :filters -This initarg accepts a list of conses, @sc{first} holding a string -that describes a filter, e.g., @samp{Text Files}, and @sc{second} +This initarg accepts a list of conses, @sc{car} holding a string +that describes a filter, e.g., @samp{Text Files}, and @sc{cdr} specifying the actual filter pattern, e.g., @samp{*.TXT}. Note that multiple filter patterns can be grouped with a single description by separating them with semicolons, e.g., @samp{*.TXT;*.BAK}. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed May 10 21:21:49 2006 @@ -224,6 +224,7 @@ #:button #:caret #:control + #:dialog #:display #:event-dispatcher #:event-source Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 21:21:49 2006 @@ -118,13 +118,36 @@ :initial-directory #P"c:/") (print paths))) +(defclass dlg-test-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfs:make-size :width 180 :height 100)) + +(defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) + (declare (ignore time rect)) + (let ((parent (gfw:parent panel))) + (setf (gfg:background-color gc) (gfg:background-color parent)) + (setf (gfg:foreground-color gc) (gfg:background-color parent)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) + (defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect))) -#| - (let ((dlg (make-instance 'gfw:dialog :owner *main-win* - :style '(:modal)))) + (declare (ignore disp item time rect)) + (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 4 + :style '(:vertical)) + :style '(:modal))) + (panel (make-instance 'dlg-test-panel + :style '(:border) + :parent dlg)) + (btn (make-instance 'gfw:button + :parent dlg))) + (setf (gfw:text btn) "Close") + (gfw:pack dlg) + (gfw:center-on-owner dlg) (gfw:show dlg t))) -|# (defun open-modeless-dlg (disp item time rect) (declare (ignore disp item time rect))) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Wed May 10 21:21:49 2006 @@ -39,8 +39,7 @@ (defmethod compute-style-flags ((btn button) style &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags 0) - (ex-flags 0)) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button @@ -50,16 +49,16 @@ ;; primary button styles ;; ((eq sym :check-box) - (setf std-flags gfs::+bs-checkbox+)) + (setf std-flags (logior std-flags gfs::+bs-checkbox+))) ((eq sym :default-button) - (setf std-flags gfs::+bs-defpushbutton+)) + (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) ((eq sym :push-button) - (setf std-flags gfs::+bs-pushbutton+)) + (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) - (setf std-flags gfs::+bs-radiobutton+)) + (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) ((eq sym :toggle-button) - (setf std-flags gfs::+bs-pushbox+)))) - (values std-flags ex-flags))) + (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (values std-flags 0))) (defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) (if (not (listp style)) @@ -69,7 +68,7 @@ (let ((hwnd (create-window gfs::+button-classname+ " " (gfs:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + std-style ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed May 10 21:21:49 2006 @@ -33,21 +33,40 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +default-dialog-title+ " ") + ;;; ;;; helper functions ;;; -#| -(defun register-user-dialog-class () - (register-window-class +user-dialog-classname+ - (cffi:get-callback 'uit_dialog_wndproc) +(defun register-dialog-class () + (register-window-class +dialog-classname+ + (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ gfs::+cs-bytealignwindow+) gfs::+color-btnface+)) -|# ;;; ;;; methods ;;; +(defmethod gfg:background-color ((dlg dialog)) + (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) + +(defmethod compute-style-flags ((dlg dialog) style &rest extra-data) + (declare (ignore style extra-data)) + (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) + (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) + +(defmethod event-close ((self event-dispatcher) (dlg dialog) time) + (declare (ignore time)) + (show dlg nil)) + +(defmethod initialize-instance :after ((dlg dialog) &key owner style title &allow-other-keys) + (unless (null owner) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error))) + (if (null title) + (setf title +default-dialog-title+)) + (init-window dlg +dialog-classname+ #'register-dialog-class style owner title)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Wed May 10 21:21:49 2006 @@ -95,14 +95,16 @@ (declare (ignore label)) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) - (values (cond - ((first extra-data) - (compute-image-style-flags (gfs:flatten style))) - ((second extra-data) - (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) - (t - (compute-text-style-flags (gfs:flatten style)))) - 0)) + (let ((std-style (logior gfs::+ws-child+ + gfs::+ws-visible+ + (cond + ((first extra-data) + (compute-image-style-flags (gfs:flatten style))) + ((second extra-data) + (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (t + (compute-text-style-flags (gfs:flatten style))))))) + (values std-style 0))) (defmethod image ((label label)) (if (gfs:disposed-p label) @@ -158,7 +160,7 @@ (let ((hwnd (create-window gfs::+static-classname+ (or text " ") (gfs:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + (logior std-style) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed May 10 21:21:49 2006 @@ -61,7 +61,7 @@ ;;; (defmethod compute-style-flags ((win top-level) style &rest extra-data) - (declare (ignore win extra-data)) + (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 21:21:49 2006 @@ -34,9 +34,9 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +dialog-classname+ "GraphicFormsDialog") (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") - (defconstant +user-dialog-classname+ "GraphicFormsUserDialog")) + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) ;;; ;;; helper functions @@ -77,6 +77,7 @@ (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) +(format t "~a~%" child) (call-child-visitor-func tc parent child))) 1) From junrue at common-lisp.net Thu May 11 02:49:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 10 May 2006 22:49:06 -0400 (EDT) Subject: [graphic-forms-cvs] r125 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060511024906.7D1CF3300A@common-lisp.net> Author: junrue Date: Wed May 10 22:49:06 2006 New Revision: 125 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: rewrote compute-outer-size in terms of AdjustWindowRectEx, which bases its calculation on window styles Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 22:49:06 2006 @@ -122,7 +122,7 @@ (defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (gfs:make-size :width 180 :height 100)) + (gfs:make-size :width 280 :height 200)) (defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) (declare (ignore time rect)) @@ -137,7 +137,7 @@ :layout (make-instance 'gfw:flow-layout :margins 8 :spacing 4 - :style '(:vertical)) + :style '(:horizontal)) :style '(:modal))) (panel (make-instance 'dlg-test-panel :style '(:border) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed May 10 22:49:06 2006 @@ -39,6 +39,14 @@ (load-foreign-library "user32.dll") (defcfun + ("AdjustWindowRectEx" adjust-window-rect) + BOOL + (rect LPTR) + (style LONG) + (menu BOOL) + (exstyle LONG)) + +(defcfun ("BeginDeferWindowPos" begin-defer-window-pos) HANDLE (numwin INT)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed May 10 22:49:06 2006 @@ -86,10 +86,15 @@ (defmethod border-width ((widget widget)) (let* ((hwnd (gfs:handle widget)) (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) - (when (logand bits gfs::+ws-ex-clientedge+) - (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) - (when (logand bits gfs::+ws-ex-staticedge+) - (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) + (cond + ((/= (logand bits gfs::+ws-ex-clientedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) + ((/= (logand bits gfs::+ws-ex-dlgmodalframe+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+))) + ((/= (logand bits gfs::+ws-ex-staticedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) + ((/= (logand bits gfs::+ws-ex-windowedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (when (logand bits gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 22:49:06 2006 @@ -77,7 +77,6 @@ (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) -(format t "~a~%" child) (call-child-visitor-func tc parent child))) 1) @@ -168,17 +167,22 @@ color)) (defmethod compute-outer-size ((win window) desired-client-size) - ;; TODO: consider reimplementing this with AdjustWindowRect - ;; - (let ((client-sz (client-size win)) - (outer-sz (size win)) - (trim-sz (gfs:make-size :width (gfs:size-width desired-client-size) - :height (gfs:size-height desired-client-size)))) - (incf (gfs:size-width trim-sz) (- (gfs:size-width outer-sz) - (gfs:size-width client-sz))) - (incf (gfs:size-height trim-sz) (- (gfs:size-height outer-sz) - (gfs:size-height client-sz))) - trim-sz)) + (let ((hwnd (gfs:handle win)) + (new-size (gfs:make-size))) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) rect-ptr gfs::rect) + (setf gfs::left 0 + gfs::top 0 + gfs::right (gfs:size-width desired-client-size) + gfs::bottom (gfs:size-height desired-client-size)) + (if (zerop (gfs::adjust-window-rect rect-ptr + (gfs::get-window-long hwnd gfs::+gwl-style+) + (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (error 'gfs:toolkit-error :detail "adjust-window-rect failed")) + (setf (gfs:size-width new-size) (- gfs::right gfs::left) + (gfs:size-height new-size) (- gfs::bottom gfs::top)))) + new-size)) (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) From junrue at common-lisp.net Thu May 11 20:41:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 11 May 2006 16:41:48 -0400 (EDT) Subject: [graphic-forms-cvs] r126 - in trunk: docs/manual src src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060511204148.CA53367001@common-lisp.net> Author: junrue Date: Thu May 11 16:41:47 2006 New Revision: 126 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: refactored message loop in preparation for supporting app-defined dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 11 16:41:47 2006 @@ -577,9 +577,27 @@ @node event functions @section event functions - at strong{NOTE:} There are (and will be) additional event methods defined -in future releases, they just aren't all documented or implemented at -this time. + at anchor{default-message-filter} + at deffn Function default-message-filter gm-code msg-ptr +Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and + at ref{control}s. Accelerator keys are also translated by this +function. Returns @sc{nil} so that @ref{message-loop} will continue, +unless @code{gm-code} is less than or equal to zero, in which case + at sc{t} is returned so that @ref{message-loop} will +exit. @code{gm-code} is zero when @code{msg-ptr} identifies a + at sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is +-1, then the system has indicated an error during message retrieval +that should be reported, followed by an orderly +shutdown. @xref{dialog-message-filter}. + at end deffn + + at anchor{dialog-message-filter} + at deffn Function dialog-message-filter gm-code msg-ptr +This function is similar to @ref{default-message-filter}, except that +it is intended to be called from a nested @code{message-loop} +invocation, usually on behalf of a modal @ref{dialog}. In this case, +the function returns @sc{nil} as long as the dialog continues to live. + at end deffn @deffn GenericFunction event-activate dispatcher widget time Implement this to respond to an object being activated. @@ -656,6 +674,23 @@ Implement this to respond to a tick from a specific timer. @end deffn + at anchor{message-loop} + at deffn Function message-loop msg-filter +This function retrieves messages from the system with the intent of +passing each one to the function specified by @code{msg-filter} so +that it may be translated and dispatched. The return value of the + at code{msg-filter} function determines whether @code{message-loop} +continues or returns, and this termination condition depends on the +context of the message loop being executed. The return value is + at sc{nil} if @code{message-loop} should continue, or not @sc{nil} if +the loop should exit. Two pre-defined implementations of message +filter functions are provided: + at itemize @bullet + at item @ref{default-message-filter} + at item @ref{dialog-message-filter} + at end itemize + at end deffn + @node widget functions @section widget functions Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 11 16:41:47 2006 @@ -342,6 +342,7 @@ #:cursor #:cut #:default-item + #:default-message-filter #:defmenu #:delay-of #:disabled-image @@ -420,6 +421,7 @@ #:maximum-size #:menu #:menu-bar + #:message-loop #:minimum-size #:mouse-over-image #:move-above @@ -446,7 +448,6 @@ #:resizable-p #:retrieve-span #:right-margin-of - #:run-default-message-loop #:scroll #:select #:select-all Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 16:41:47 2006 @@ -397,6 +397,12 @@ (erase BOOL)) (defcfun + ("IsDialogMessageA" is-dialog-message) + BOOL + (hwnd HANDLE) + (msg LPTR)) + +(defcfun ("IsWindowEnabled" is-window-enabled) BOOL (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 11 16:41:47 2006 @@ -66,7 +66,7 @@ ;;; helper functions ;;; -(defun run-default-message-loop () +(defun message-loop (msg-filter) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) @@ -78,14 +78,8 @@ gfs::pnt) msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) - (when (zerop gm) - (dispose-thread-context) - (return-from run-default-message-loop gfs::wparam)) - (when (= gm -1) - (warn 'gfs:win32-warning :detail "get-message failed") - (return-from run-default-message-loop gfs::wparam))) - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr))))) + (when (funcall msg-filter gm msg-ptr) + (return-from message-loop gfs::wparam))))))) (defmacro hi-word (lparam) `(ash (logand #xFFFF0000 ,lparam) -16)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu May 11 16:41:47 2006 @@ -33,11 +33,24 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun default-message-filter (gm-code msg-ptr) + (cond + ((zerop gm-code) + (dispose-thread-context) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + (t + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr) + nil))) + #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (gfg::initialize-magick (cffi:null-pointer)) (funcall start-fn) - (run-default-message-loop)) + (message-loop #'default-message-filter)) #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) @@ -46,9 +59,9 @@ (mp:initialize-multiprocessing)) (mp:process-run-function thread-name nil - #'(lambda () (progn - (funcall start-fn) - (run-default-message-loop))))) + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfg::destroy-magick) From junrue at common-lisp.net Fri May 12 03:20:05 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 11 May 2006 23:20:05 -0400 (EDT) Subject: [graphic-forms-cvs] r127 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060512032005.4F4537A008@common-lisp.net> Author: junrue Date: Thu May 11 23:20:03 2006 New Revision: 127 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored compute-style-flags GF and implementations; added utility function for traversing top-level windows owned by UI thread Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 11 23:20:03 2006 @@ -189,10 +189,36 @@ @anchor{dialog} @deftp Class dialog This is the base class for system and application-defined dialogs. A -dialog is a windowed UI component that is @emph{typically} defined to -remain on top of the primary application window(s). Of course, some +dialog is a windowed UI component, usually containing at least one + at ref{panel} or @ref{control}, that remains on top of application + at ref{window}(s). Dialogs typically serve to collect additional +information from the user in a specific context. Note that some applications are entirely dialog-based. This class derives from - at ref{window}. + at ref{window}.@*@* A @emph{modal} dialog constrains the user to respond +to it, whereas a @emph{modeless} dialog allows continued interaction +with other windows. + at deffn Initarg :owner +Specifies the @ref{owner} of the dialog. + at end deffn + at deffn Initarg :style + at table @code + at item :application-modal +Specifies that the dialog is @emph{modal} with respect to all + at ref{top-level} windows and @ref{dialog}s created by the application +(specifically those created by the calling thread which are still +realized on-screen). + at item :modeless +Specifies that the dialog is @emph{modeless}, meaning that while the +dialog floats on top of all application-created windows, the user may +still interact with other windows and dialogs. + at item :owner-modal +Specifies that the dialog is @emph{modal} only in terms of its + at ref{owner} window or dialog. + at end table + at end deffn + at deffn Initarg :text +Specifies the dialog's title. + at end deffn @end deftp @anchor{display} @@ -485,19 +511,19 @@ @end deftp @anchor{widget} - at deftp Class widget + at deftp Class widget style The widget class is the base class for all windowed user interface objects. It -derives from @ref{event-source}. +derives from @ref{event-source}. The @code{style} slot is a list of keyword +symbols supplying additional information about the desired look-and-feel or +behavior of the widget; style keywords are widget-specific. @end deftp - at anchor{widget-with-items} + at anchor{widget-with-items} items @deftp Class widget-with-items -The widget-with-items class is the base class for objects composed of sub-items. -It derives from @ref{widget}. - at deffn Initarg :items - at end deffn - at deffn Accessor items - at end deffn +The widget-with-items class is the base class for objects composed of +sub-items. It derives from @ref{widget}. The @code{items} slot is an + at sc{adjustable} @sc{vector} containing @ref{item} objects, +representing sub-elements of the widget. @end deftp @anchor{window} @@ -583,20 +609,11 @@ @ref{control}s. Accelerator keys are also translated by this function. Returns @sc{nil} so that @ref{message-loop} will continue, unless @code{gm-code} is less than or equal to zero, in which case - at sc{t} is returned so that @ref{message-loop} will -exit. @code{gm-code} is zero when @code{msg-ptr} identifies a - at sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is --1, then the system has indicated an error during message retrieval -that should be reported, followed by an orderly -shutdown. @xref{dialog-message-filter}. - at end deffn - - at anchor{dialog-message-filter} - at deffn Function dialog-message-filter gm-code msg-ptr -This function is similar to @ref{default-message-filter}, except that -it is intended to be called from a nested @code{message-loop} -invocation, usually on behalf of a modal @ref{dialog}. In this case, -the function returns @sc{nil} as long as the dialog continues to live. + at sc{t} is returned so that @ref{message-loop} will exit. When + at code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT} +message indicating normal shutdown. If @code{gm-code} is -1, then the +system has reported an error during message retrieval which should be +handled by (hopefully) graceful shutdown. @end deffn @deffn GenericFunction event-activate dispatcher widget time @@ -683,12 +700,8 @@ continues or returns, and this termination condition depends on the context of the message loop being executed. The return value is @sc{nil} if @code{message-loop} should continue, or not @sc{nil} if -the loop should exit. Two pre-defined implementations of message -filter functions are provided: - at itemize @bullet - at item @ref{default-message-filter} - at item @ref{dialog-message-filter} - at end itemize +the loop should exit. The pre-defined implementation + at ref{default-message-filter} is provided. @end deffn @@ -752,10 +765,10 @@ be drawn within or can display data. @end deffn - at deffn GenericFunction compute-style-flags self &rest style -Convert a list of keyword symbols to a pair of native bitmasks; the -first conveys normal/standard flags, whereas the second any extended -flags that the system supports. + at deffn GenericFunction compute-style-flags self &rest extra-data +Convert a list of keyword symbols in the object's @code{style} slot to +a values pair of native bitmasks; the first conveys normal/standard +flags, whereas the second any extended flags that the system supports. @end deffn @deffn GenericFunction compute-outer-size self desired-client-size Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 23:20:03 2006 @@ -236,6 +236,42 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("EnumThreadWindows" enum-thread-windows) + BOOL + (threadid DWORD) + (func :pointer) + (lparam LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-thread-windows "EnumThreadWindows") + ((threadid (:unsigned :long)) + (func :pointer) + (lparam :long)) + :result-type :int) + +#+clisp +(ffi:def-call-out enum-thread-windows + (:name "EnumThreadWindows") + (:library "user32.dll") + (:language :stdc) + (:arguments (threadid ffi:ulong) + (func (ffi:c-function + (:arguments + (hwnd ffi:c-pointer) + (lparam ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (lparam ffi:long)) + (:return-type ffi:int)) + (defcfun ("GetAncestor" get-ancestor) HANDLE @@ -382,6 +418,12 @@ (max INT)) (defcfun + ("GetWindowThreadProcessId" get-window-thread-process-id) + DWORD + (hwnd HANDLE) + (pid LPTR)) + +(defcfun ("InsertMenuItemA" insert-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu May 11 23:20:03 2006 @@ -37,14 +37,13 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) style &rest extra-data) +(defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) - (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button ;; - (loop for sym in style + (loop for sym in (style-of btn) do (cond ;; primary button styles ;; @@ -60,11 +59,9 @@ (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) - (if (not (listp style)) - (setf style (list style))) +(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys) (multiple-value-bind (std-style ex-style) - (compute-style-flags btn style) + (compute-style-flags btn) (let ((hwnd (create-window gfs::+button-classname+ " " (gfs:handle parent) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu May 11 23:20:03 2006 @@ -54,8 +54,8 @@ (defmethod gfg:background-color ((dlg dialog)) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) -(defmethod compute-style-flags ((dlg dialog) style &rest extra-data) - (declare (ignore style extra-data)) +(defmethod compute-style-flags ((dlg dialog) &rest extra-data) + (declare (ignore extra-data)) (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) @@ -63,10 +63,10 @@ (declare (ignore time)) (show dlg nil)) -(defmethod initialize-instance :after ((dlg dialog) &key owner style title &allow-other-keys) +(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) - (if (null title) - (setf title +default-dialog-title+)) - (init-window dlg +dialog-classname+ #'register-dialog-class style owner title)) + (if (null text) + (setf text +default-dialog-title+)) + (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu May 11 23:20:03 2006 @@ -83,6 +83,43 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) +#+lispworks +(fli:define-foreign-callable + ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) + (let* ((tc (thread-context)) + (win (get-widget tc hwnd))) + (unless (null win) + (call-top-level-visitor-func tc win))) + 1) + +#+clisp +(defun top_level_window_visitor (hwnd lparam) + (declare (ignore lparam)) + (let* ((tc (thread-context)) + (win (get-widget tc hwnd))) + (unless (null win) + (call-top-level-visitor-func tc win))) + 1) + +(defun visit-top-level-windows (func) + ;; + ;; supplied closure should expect one parameter: + ;; top-level window + ;; + (let ((tc (thread-context))) + (setf (top-level-visitor-func tc) func) + (unwind-protect +#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (fli:make-pointer :symbol-name "top_level_window_visitor") + 0) +#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + #'top_level_window_visitor + 0) + (setf (top-level-visitor-func tc) nil))) + nil) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Thu May 11 23:20:03 2006 @@ -74,12 +74,12 @@ ;;; methods ;;; -(defmethod compute-style-flags ((dlg file-dialog) style &rest extra-data) +(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+ gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+ gfs::+ofn-explorer+))) - (loop for sym in style + (loop for sym in (style-of dlg) do (cond ((eq sym :add-to-recent) (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) @@ -137,7 +137,7 @@ (gfs::strncpy file-buffer tmp-str 1023)) (setf (cffi:mem-ref file-buffer :char) 0)) (multiple-value-bind (std-style ex-style) - (compute-style-flags dlg style) + (compute-style-flags dlg) (cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu May 11 23:20:03 2006 @@ -91,19 +91,20 @@ (setf (gfg:transparency-pixel-of image) pnt)) (setf (image label) image)))) -(defmethod compute-style-flags ((label label) style &rest extra-data) - (declare (ignore label)) +(defmethod compute-style-flags ((label label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) (let ((std-style (logior gfs::+ws-child+ gfs::+ws-visible+ (cond ((first extra-data) - (compute-image-style-flags (gfs:flatten style))) + (compute-image-style-flags (style-of label))) ((second extra-data) - (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (if (find :vertical (style-of label)) + gfs::+ss-etchedvert+ + gfs::+ss-etchedhorz+)) (t - (compute-text-style-flags (gfs:flatten style))))))) + (compute-text-style-flags (style-of label))))))) (values std-style 0))) (defmethod image ((label label)) @@ -152,11 +153,9 @@ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys) - (if (not (listp style)) - (setf style (list style))) +(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) (multiple-value-bind (std-style ex-style) - (compute-style-flags label style image separator text) + (compute-style-flags label image separator text) (let ((hwnd (create-window gfs::+static-classname+ (or text " ") (gfs:handle parent) @@ -201,7 +200,7 @@ (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) - (compute-style-flags label nil nil nil str) + (compute-style-flags label nil nil str) (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu May 11 23:20:03 2006 @@ -49,24 +49,21 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) style &rest extra-data) +(defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) - (ex-flags 0)) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) (mapc #'(lambda (sym) (cond ;; styles that can be combined ;; ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) - (gfs:flatten style)) - (values std-flags ex-flags))) + (style-of self)) + (values std-flags 0))) -(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (if (not (listp style)) - (setf style (list style))) - (init-window self +panel-window-classname+ #'register-panel-window-class style parent "")) + (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu May 11 23:20:03 2006 @@ -34,23 +34,24 @@ (in-package #:graphic-forms.uitoolkit.widgets) (defclass thread-context () - ((child-visitor-stack :initform nil) - (display-visitor-func :initform nil :accessor display-visitor-func) - (image-loaders-by-type :initform (make-hash-table :test #'equal)) - (job-table :initform (make-hash-table :test #'equal)) - (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) - (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) - (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)) + ((child-visitor-stack :initform nil) + (display-visitor-func :initform nil :accessor display-visitor-func) + (image-loaders-by-type :initform (make-hash-table :test #'equal)) + (job-table :initform (make-hash-table :test #'equal)) + (job-table-lock :initform nil) + (event-time :initform 0 :accessor event-time) + (virtual-key :initform 0 :accessor virtual-key) + (menuitems-by-id :initform (make-hash-table :test #'equal)) + (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)) + (top-level-visitor-func :initform nil :accessor top-level-visitor-func) + (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.")) ;; TODO: change this when CLISP acquires MT support @@ -122,6 +123,11 @@ (unless (null func) (funcall func hmonitor data)))) +(defmethod call-top-level-visitor-func ((tc thread-context) win) + (let ((func (top-level-visitor-func tc))) + (unless (null func) + (funcall func win)))) + (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 11 23:20:03 2006 @@ -60,7 +60,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) style &rest extra-data) +(defmethod compute-style-flags ((win top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) @@ -114,7 +114,7 @@ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) (setf ex-flags 0)))) - (gfs:flatten style)) + (style-of win)) (values std-flags ex-flags))) (defmethod gfs:dispose ((win top-level)) @@ -124,20 +124,18 @@ (remove-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) +(defmethod initialize-instance :after ((win top-level) &key owner title &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null title) (setf title +default-window-title+)) - (if (not (listp style)) - (setf style (list style))) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace style) + (when (find :workspace (style-of win)) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func style owner title))) + (init-window win classname register-func owner title))) (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 11 23:20:03 2006 @@ -59,7 +59,11 @@ (defclass menu-item (item) () (:documentation "A subtype of item representing a menu item.")) -(defclass widget (event-source) () +(defclass widget (event-source) + ((style + :reader style-of + :initarg :style + :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) (defclass caret (widget) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 11 23:20:03 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self style &rest extra-data) +(defgeneric compute-style-flags (self &rest extra-data) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu May 11 23:20:03 2006 @@ -167,6 +167,9 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) + (setf (slot-value w 'style) (if (listp style) style (list style)))) + (defmethod location :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu May 11 23:20:03 2006 @@ -42,12 +42,12 @@ ;;; helper functions ;;; -(defun init-window (win classname register-class-fn style parent text) +(defun init-window (win classname register-class-fn parent text) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (funcall register-class-fn) (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) + (compute-style-flags win) (create-window classname text (if (null parent) (cffi:null-pointer) (gfs:handle parent)) @@ -75,7 +75,7 @@ (defun child_window_visitor (hwnd lparam) (let* ((tc (thread-context)) (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) + (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) (call-child-visitor-func tc parent child))) 1) From junrue at common-lisp.net Fri May 12 17:20:57 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 12 May 2006 13:20:57 -0400 (EDT) Subject: [graphic-forms-cvs] r128 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060512172057.81C317700E@common-lisp.net> Author: junrue Date: Fri May 12 13:20:56 2006 New Revision: 128 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: dialog :owner-modal and :modeless styles now work, but :application-modal style needs further work Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri May 12 13:20:56 2006 @@ -194,11 +194,14 @@ @ref{window}(s). Dialogs typically serve to collect additional information from the user in a specific context. Note that some applications are entirely dialog-based. This class derives from - at ref{window}.@*@* A @emph{modal} dialog constrains the user to respond -to it, whereas a @emph{modeless} dialog allows continued interaction -with other windows. + at ref{window}.@*@* A @emph{modal} dialog forces the user to respond to +it before returning to other application functionality, whereas a + at emph{modeless} dialog does not. @deffn Initarg :owner -Specifies the @ref{owner} of the dialog. +Specifies the @ref{owner} of the dialog. Although no error will be +thrown, the library does not allow @ref{root-window} to be the parent +of any dialog -- the dialog initialization code instead substitutes + at sc{nil} for the owner. @end deffn @deffn Initarg :style @table @code @@ -212,8 +215,9 @@ dialog floats on top of all application-created windows, the user may still interact with other windows and dialogs. @item :owner-modal -Specifies that the dialog is @emph{modal} only in terms of its - at ref{owner} window or dialog. +Specifies that the dialog is @emph{modal} only in relation to its + at ref{owner} (which could be a window or another dialog). This style is +the default if no style keywords are specified. @end table @end deffn @deffn Initarg :text @@ -432,11 +436,10 @@ on the root @ref{window} are somewhat constrained, therefore not all functions normally implemented for other @ref{window} types are available for this @ref{window} type. If an application attempts to -set @code{root-window} as the @ref{owner} of a dialog or - at ref{top-level}, a @ref{toolkit-error} will be thrown. -In a reply to an entry at - at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, -Raymond Chen says: +set @code{root-window} as the @ref{owner} of a dialog, the library +will substitute @sc{nil}. This follows guidance provided by Raymond +Chen in a reply to an entry at his blog + at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}: @quotation An owned window is not a child window. Disabling a parent also disables children, but it does NOT disable owned windows. @@ -639,7 +642,7 @@ @end deffn @anchor{event-focus-loss} - at deffn GenericFunction event-focus-gain dispatcher widget time + at deffn GenericFunction event-focus-loss dispatcher widget time Implement this to respond to an object losing keyboard focus. @end deffn Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri May 12 13:20:56 2006 @@ -131,26 +131,46 @@ (setf (gfg:foreground-color gc) (gfg:background-color parent)) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) -(defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defclass dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) + (declare (ignore time)) + (format t "dialog-events event-close called~%") + (call-next-method) + (gfs:dispose dlg)) + +(defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 4 - :style '(:horizontal)) - :style '(:modal))) + :dispatcher (make-instance 'dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 4 + :style '(:horizontal)) + :style style + :text title)) (panel (make-instance 'dlg-test-panel :style '(:border) :parent dlg)) (btn (make-instance 'gfw:button + :callback (lambda (disp btn time rect) + (declare (ignore disp time rect)) + (let ((dlg (gfw:parent btn))) + (gfw:show dlg nil) + (gfs:dispose dlg))) :parent dlg))) (setf (gfw:text btn) "Close") (gfw:pack dlg) (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (gfw:show dlg t) + dlg)) + +(defun open-modal-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (open-dlg "Modal" '(:owner-modal))) (defun open-modeless-dlg (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () (let ((menubar nil)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri May 12 13:20:56 2006 @@ -69,4 +69,56 @@ (error 'gfs:disposed-error))) (if (null text) (setf text +default-dialog-title+)) + ;; NOTE: do not allow apps to specify the desktop window as the + ;; owner of the dialog; it would cause the desktop to become + ;; disabled. + ;; + (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) + (setf owner nil)) (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) + +(defmethod show ((dlg dialog) flag) + (let ((hutility (utility-hwnd (thread-context))) + (app-modal (find :application-modal (style-of dlg))) + (owner-modal (find :owner-modal (style-of dlg))) + (owner (owner dlg)) + (hdlg (gfs:handle dlg))) + (cond + ((and app-modal owner) + ;; FIXME: need to save and restore each window's prior + ;; enabled state + ;; + (visit-top-level-windows (lambda (win) + (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) + (cffi:pointer-eq (gfs:handle win) hutility)) + (enable win (null flag)))))) + ((and owner-modal owner) + (enable owner (null flag)))) + (call-next-method) + (when (and flag (or app-modal owner-modal)) + (message-loop (lambda (gm-code msg-ptr) + (cond + ((or (gfs:disposed-p dlg) (not (visible-p dlg))) + t) ; dialog closed, so exit loop + ((zerop gm-code) + ;; IMPORTANT: allow WM_QUIT to propagate back through + ;; nested message loops to the main loop, so that we + ;; shut down correctly -- whether the system injected + ;; the WM_QUIT or it was something the app did, we + ;; handle the shutdown request the same way. + ;; + (gfs::post-quit-message (cffi:foreign-slot-value msg-ptr + 'gfs::msg + 'gfs::wparam)) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0) + ;; It was a dialog message and has been processed, + ;; so nothing else to do. + ;; + nil) + (t + (translate-and-dispatch msg-ptr) + nil))))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri May 12 13:20:56 2006 @@ -33,6 +33,10 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun translate-and-dispatch (msg-ptr) + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr)) + (defun default-message-filter (gm-code msg-ptr) (cond ((zerop gm-code) @@ -42,8 +46,7 @@ (warn 'gfs:win32-warning :detail "get-message failed") t) (t - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr) + (translate-and-dispatch msg-ptr) nil))) #+clisp (defun startup (thread-name start-fn) From junrue at common-lisp.net Sat May 13 16:51:00 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 13 May 2006 12:51:00 -0400 (EDT) Subject: [graphic-forms-cvs] r129 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060513165100.1B8C063020@common-lisp.net> Author: junrue Date: Sat May 13 12:50:58 2006 New Revision: 129 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.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-utils.lisp Log: implement :text initarg for buttons; generalize timer id counter in thread-context to all widgets except menu items; specify a runtime-unique ID for every widget; assorted bug fixes for WM_COMMAND process-message Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat May 13 12:50:58 2006 @@ -175,9 +175,17 @@ @strong{NOTE:} A future release will provide additional widget classes. + at anchor{button} @deftp Class button This @ref{control} class represents selectable controls that issue -notifications when clicked. +notifications when clicked.@*@* +The following initargs are supported: + at deffn Initarg :image + at end deffn + at deffn Initarg :style + at end deffn + at deffn Initarg :text + at end deffn @end deftp @anchor{control} @@ -711,10 +719,6 @@ @node widget functions @section widget functions - at strong{NOTE:} There are (and will be) additional widget methods defined -in future releases, they just aren't all documented or implemented at -this time. - @deffn GenericFunction ancestor-p ancestor descendant Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn @@ -779,6 +783,13 @@ enclose the specified desired client area and this object's trim. @end deffn + at deffn GenericFunction default-button self button +Returns the default @ref{button} set for a @ref{dialog}, or @sc{nil} +if none has been set. If @code{button} is @sc{nil}, then no default +button is set. The default button is the button that is selected when + at code{self} is active and the user presses @sc{enter}. + at end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 12:50:58 2006 @@ -139,6 +139,12 @@ (call-next-method) (gfs:dispose dlg)) +(defun btn-callback (disp btn time rect) + (declare (ignore disp time rect)) + (let ((dlg (gfw:parent btn))) + (gfw:show dlg nil) + (gfs:dispose dlg))) + (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -151,14 +157,20 @@ (panel (make-instance 'dlg-test-panel :style '(:border) :parent dlg)) - (btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp time rect)) - (let ((dlg (gfw:parent btn))) - (gfw:show dlg nil) - (gfs:dispose dlg))) - :parent dlg))) - (setf (gfw:text btn) "Close") + (btn-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :spacing 4 + :style '(:vertical)) + :parent dlg)) + (ok-btn (make-instance 'gfw:button + :callback #'btn-callback + :text "OK" + :parent btn-panel)) + (cancel-btn (make-instance 'gfw:button + :callback #'btn-callback + :style '(:push-button) + :text "Cancel" + :parent btn-panel))) (gfw:pack dlg) (gfw:center-on-owner dlg) (gfw:show dlg t) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 12:50:58 2006 @@ -40,9 +40,6 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) - ;; FIXME: check whether any of the primary button - ;; styles were specified, default to :push-button - ;; (loop for sym in (style-of btn) do (cond ;; primary button styles @@ -59,11 +56,11 @@ (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) (multiple-value-bind (std-style ex-style) (compute-style-flags btn) (let ((hwnd (create-window gfs::+button-classname+ - " " + (or text " ") (gfs:handle parent) std-style ex-style))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 12:50:58 2006 @@ -137,30 +137,32 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) (let* ((tc (thread-context)) (wparam-hi (hi-word wparam)) + (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) +(format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner (cond ((zerop lparam) - (let ((item (get-menuitem tc (lo-word wparam)))) + (let ((item (get-menuitem tc wparam-lo))) (if (null item) - (error 'gfs:toolkit-error :detail "no menu item for id")) - (unless (null (dispatcher item)) - (event-select (dispatcher item) - item - (event-time tc) - (make-instance 'gfs:rectangle))))) ; FIXME + (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) + (unless (null (dispatcher item)) + (event-select (dispatcher item) + item + (event-time tc) + (make-instance 'gfs:rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) - (error 'gfs:toolkit-error :detail "no object for hwnd")) - (unless (null (dispatcher w)) - (event-select (dispatcher w) - w - (event-time tc) - (make-instance 'gfs:rectangle)))))) ; FIXME - (error 'gfs:toolkit-error :detail "no object for hwnd"))) + (warn 'gfs:toolkit-warning :detail "no object for hwnd") + (unless (null (dispatcher w)) + (event-select (dispatcher w) + w + (event-time tc) + (make-instance 'gfs:rectangle))))))) ; FIXME + (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat May 13 12:50:58 2006 @@ -45,7 +45,7 @@ (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) + (next-widget-id :initform 100 :reader next-widget-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)) @@ -198,8 +198,8 @@ (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) -(defmethod increment-timer-id ((tc thread-context)) +(defmethod increment-widget-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)) + (let ((id (next-widget-id tc))) + (incf (slot-value tc 'next-widget-id)) id)) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sat May 13 12:50:58 2006 @@ -63,7 +63,7 @@ (let ((tc (thread-context)) (id (id-of timer))) (when (zerop id) - (setf (slot-value timer 'id) (increment-timer-id tc)) + (setf (slot-value timer 'id) (increment-widget-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"))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat May 13 12:50:58 2006 @@ -75,7 +75,7 @@ (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) -(defun create-window (class-name title parent-hwnd std-style ex-style) +(defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) (gfs::create-window @@ -88,7 +88,9 @@ gfs::+cw-usedefault+ gfs::+cw-usedefault+ parent-hwnd - (cffi:null-pointer) + (if (zerop (logand gfs::+ws-child+ std-style)) + (cffi:null-pointer) + (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) (cffi:null-pointer) 0)))) From junrue at common-lisp.net Sat May 13 23:57:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 13 May 2006 19:57:07 -0400 (EDT) Subject: [graphic-forms-cvs] r130 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060513235707.0C50A7415F@common-lisp.net> Author: junrue Date: Sat May 13 19:57:06 2006 New Revision: 130 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: progress towards proper keyboard traversal in dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat May 13 19:57:06 2006 @@ -276,7 +276,7 @@ @anchor{file-dialog} @deftp Class file-dialog open-mode -This class provides a standard @ref{dialog} for navigating the file +This class provides a standard dialog for navigating the file system to select or enter file names. A variety of configurations are possible; however, please note that the following behaviors are implemented regardless of other style flags or initarg values: @@ -290,9 +290,14 @@ steps manually, in which case the @ref{file-dialog-paths} function can be used to obtain the user's selection(s). Unless the @code{:multiple-select} style keyword is specified, there will at most -be one selected file returned, and possibly zero if the user cancelled -the dialog. Also, manual construction of an instance must be followed -by an explicit call to @ref{dispose}.@*@* +be one selected file returned. In either case, zero is returned if the +user cancelled the dialog. Also, manual construction of an instance +must be followed by an explicit call to @ref{dispose}.@*@* +Like other system dialogs, @code{file-dialog} is derived from @ref{widget} +rather than @ref{dialog} since the majority of its functionality is +implemented by the system and is not directly extensible by applications. + at strong{NOTE:} A future release of Graphic-Forms will provide a +customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if the user fails to provide one. Any embedded periods @samp{.} will @@ -783,11 +788,12 @@ enclose the specified desired client area and this object's trim. @end deffn - at deffn GenericFunction default-button self button -Returns the default @ref{button} set for a @ref{dialog}, or @sc{nil} -if none has been set. If @code{button} is @sc{nil}, then no default -button is set. The default button is the button that is selected when - at code{self} is active and the user presses @sc{enter}. + at deffn GenericFunction default-widget self +Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} +if none has been set. If @sc{nil} is passed to the corresponding + at sc{setf} function, then no default widget is set. The default widget +is the one that is selected when @code{self} is active and the user +presses @sc{enter}. @end deffn @deffn GenericFunction display-to-object self pnt Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat May 13 19:57:06 2006 @@ -341,8 +341,8 @@ #:current-font #:cursor #:cut - #:default-item #:default-message-filter + #:default-widget #:defmenu #:delay-of #:disabled-image Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 19:57:06 2006 @@ -164,6 +164,7 @@ :parent dlg)) (ok-btn (make-instance 'gfw:button :callback #'btn-callback + :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat May 13 19:57:06 2006 @@ -72,6 +72,15 @@ (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) +(defconstant +bm-getcheck+ #x00f0) +(defconstant +bm-setcheck+ #x00f1) +(defconstant +bm-getstate+ #x00f2) +(defconstant +bm-setstate+ #x00f3) +(defconstant +bm-setstyle+ #x00f4) +(defconstant +bm-click+ #x00f5) +(defconstant +bm-getimage+ #x00f6) +(defconstant +bm-setimage+ #x00f7) + (defconstant +bs-solid+ 0) (defconstant +bs-null+ 1) (defconstant +bs-hollow+ 1) @@ -113,6 +122,12 @@ (defconstant +bs-flat+ #x00008000) (defconstant +bs-rightbutton+ #x00000020) +(defconstant +bst-unchecked+ #x0000) +(defconstant +bst-checked+ #x0001) +(defconstant +bst-indeterminate+ #x0002) +(defconstant +bst-pushed+ #x0004) +(defconstant +bst-focus+ #x0008) + (defconstant +cbm-init+ #x04) (defconstant +cchdevicename+ 32) @@ -194,6 +209,10 @@ (defconstant +dib-rgb-colors+ 0) (defconstant +dib-pal-colors+ 1) +(defconstant +dm-getdefid+ #x0400) +(defconstant +dm-setdefid+ #x0401) +(defconstant +dm-reposition+ #x0402) + (defconstant +dt-top+ #x00000000) (defconstant +dt-left+ #x00000000) (defconstant +dt-center+ #x00000001) @@ -292,6 +311,19 @@ (defconstant +hs-cross+ 4) (defconstant +hs-diagcross+ 5) +(defconstant +idok+ 1) +(defconstant +idcancel+ 2) +(defconstant +idabort+ 3) +(defconstant +idretry+ 4) +(defconstant +idignore+ 5) +(defconstant +idyes+ 6) +(defconstant +idno+ 7) +(defconstant +idclose+ 8) +(defconstant +idhelp+ 9) +(defconstant +idtryagain+ 10) +(defconstant +idcontinue+ 11) +(defconstant +idtimeout+ 32000) + (defconstant +image-bitmap+ 0) (defconstant +image-icon+ 1) (defconstant +image-cursor+ 2) @@ -766,6 +798,15 @@ (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) (defconstant +wm-getminmaxinfo+ #x0024) +(defconstant +wm-painticon+ #x0026) +(defconstant +wm-iconerasebkgnd+ #x0027) +(defconstant +wm-nextdlgctl+ #x0028) +(defconstant +wm-spoolerstatus+ #x002A) +(defconstant +wm-drawitem+ #x002B) +(defconstant +wm-measureitem+ #x002C) +(defconstant +wm-deleteitem+ #x002D) +(defconstant +wm-vkeytoitem+ #x002E) +(defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) (defconstant +wm-ncmousemove+ #x00A0) @@ -848,8 +889,10 @@ (defconstant +ws-hscroll+ #x00100000) (defconstant +ws-sysmenu+ #x00080000) (defconstant +ws-thickframe+ #x00040000) +(defconstant +ws-group+ #x00020000) (defconstant +ws-minimizebox+ #x00020000) (defconstant +ws-maximizebox+ #x00010000) +(defconstant +ws-tabstop+ #x00010000) (defconstant +ws-popupwindow+ #x80880000) (defconstant +ws-overlappedwindow+ #x00CF0000) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat May 13 19:57:06 2006 @@ -108,6 +108,14 @@ (flags UINT)) (defcfun + ("DefDlgProcA" def-dlg-proc) + LRESULT + (hwnd HANDLE) + (msg UINT) + (wp WPARAM) + (lp LPARAM)) + +(defcfun ("DefWindowProcA" def-window-proc) LRESULT (hwnd HANDLE) @@ -367,6 +375,13 @@ (monitor-info LPTR)) (defcfun + ("GetNextDlgTabItem" get-next-dlg-tab-item) + HANDLE + (hdlg HANDLE) + (hctl HANDLE) + (flag BOOL)) + +(defcfun ("GetParent" get-parent) HANDLE (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 19:57:06 2006 @@ -39,7 +39,8 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (style (style-of btn))) (loop for sym in (style-of btn) do (cond ;; primary button styles @@ -54,6 +55,8 @@ (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) ((eq sym :toggle-button) (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (if (null style) + (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) (defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) @@ -63,9 +66,12 @@ (or text " ") (gfs:handle parent) std-style - ex-style))) + ex-style + (increment-widget-id (thread-context))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) + (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) + (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) (setf (slot-value btn 'gfs:handle) hwnd))) (init-control btn)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sat May 13 19:57:06 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.widgets) (defconstant +default-dialog-title+ " ") +(defconstant +dlgwindowextra+ 48) ;;; ;;; helper functions @@ -45,7 +46,8 @@ (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ gfs::+cs-bytealignwindow+) - gfs::+color-btnface+)) + gfs::+color-btnface+ + +dlgwindowextra+)) ;;; ;;; methods @@ -63,7 +65,45 @@ (declare (ignore time)) (show dlg nil)) -(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys) +(defmethod default-widget :before ((self dialog)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod default-widget ((self dialog)) + (let ((def-widget nil)) + (visit-child-widgets self (lambda (parent kid) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) + gfs::+idok+) + (setf def-widget kid)))) + def-widget)) + +(defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) + (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) + (error 'gfs:disposed-error))) + +(defmethod (setf default-widget) ((def-widget widget) (self dialog)) + (when (or (not (typep def-widget 'button)) + (and (style-of def-widget) + (null (find :push-button (style-of def-widget))))) + (warn 'gfs:toolkit-warning :detail "only push buttons may serve as default widgets in a dialog") + (return-from default-widget nil)) + (let ((old-def-widget (default-widget self))) + (if old-def-widget + (let* ((hwnd (gfs:handle old-def-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (let* ((hdlg (gfs:handle self)) + (hwnd (gfs:handle def-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logior style gfs::+bs-defpushbutton+)) + (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) + (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address hwnd) 1) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + +(defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -75,14 +115,19 @@ ;; (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) (setf owner nil)) - (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) + ;; FIXME: check if owner is actually a top-level or dialog, and if not, + ;; walk up the ancestors until one is found. Only top level hwnds can + ;; be owners. + ;; + (init-window self +dialog-classname+ #'register-dialog-class owner text)) -(defmethod show ((dlg dialog) flag) - (let ((hutility (utility-hwnd (thread-context))) - (app-modal (find :application-modal (style-of dlg))) - (owner-modal (find :owner-modal (style-of dlg))) - (owner (owner dlg)) - (hdlg (gfs:handle dlg))) +(defmethod show ((self dialog) flag) + (let* ((tc (thread-context)) + (hutility (utility-hwnd tc)) + (app-modal (find :application-modal (style-of self))) + (owner-modal (find :owner-modal (style-of self))) + (owner (owner self)) + (hdlg (gfs:handle self))) (cond ((and app-modal owner) ;; FIXME: need to save and restore each window's prior @@ -98,7 +143,7 @@ (when (and flag (or app-modal owner-modal)) (message-loop (lambda (gm-code msg-ptr) (cond - ((or (gfs:disposed-p dlg) (not (visible-p dlg))) + ((or (gfs:disposed-p self) (not (visible-p self))) t) ; dialog closed, so exit loop ((zerop gm-code) ;; IMPORTANT: allow WM_QUIT to propagate back through @@ -114,7 +159,7 @@ ((= gm-code -1) (warn 'gfs:win32-warning :detail "get-message failed") t) - ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0) + ((/= (gfs::is-dialog-message (gfs:handle self) msg-ptr) 0) ;; It was a dialog message and has been processed, ;; so nothing else to do. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 19:57:06 2006 @@ -123,6 +123,9 @@ ;;; (defmethod process-message (hwnd msg wparam lparam) + (let ((w (get-widget (thread-context) hwnd))) + (if (typep w 'dialog) + (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) (gfs::def-window-proc hwnd msg wparam lparam)) (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) @@ -139,7 +142,6 @@ (wparam-hi (hi-word wparam)) (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) -(format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner (cond ((zerop lparam) @@ -152,7 +154,7 @@ (event-time tc) (make-instance 'gfs:rectangle)))))) ; FIXME ((eq wparam-hi 1) - (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) + (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) @@ -186,8 +188,9 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (declare (ignore wparam lparam)) - (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot + (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep w 'dialog) + (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sat May 13 19:57:06 2006 @@ -160,7 +160,8 @@ (or text " ") (gfs:handle parent) (logior std-style) - ex-style))) + ex-style + (increment-widget-id (thread-context))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value label 'gfs:handle) hwnd) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sat May 13 19:57:06 2006 @@ -59,7 +59,7 @@ ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) (style-of self)) - (values std-flags 0))) + (values std-flags gfs::+ws-ex-controlparent+))) (defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) (if (null parent) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat May 13 19:57:06 2006 @@ -93,6 +93,12 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass file-dialog (widget) + ((open-mode + :reader open-mode + :initform t)) + (:documentation "This class represents the standard file open/save dialog.")) + (defclass widget-with-items (widget) ((items :accessor items @@ -116,12 +122,6 @@ (defclass dialog (window) () (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) -(defclass file-dialog (dialog) - ((open-mode - :reader open-mode - :initform t)) - (:documentation "This class represents the standard file open/save dialog.")) - (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat May 13 19:57:06 2006 @@ -120,8 +120,8 @@ (defgeneric cut (self) (:documentation "Copies the current selection to the clipboard and removes it from the object.")) -(defgeneric default-item (self) - (:documentation "Returns the item in this object that has the default emphasis.")) +(defgeneric default-widget (self) + (:documentation "Returns the child widget or item that has the default emphasis.")) (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat May 13 19:57:06 2006 @@ -82,7 +82,7 @@ ex-style cname-ptr title-ptr - std-style + (if child-id (logior std-style gfs::+ws-tabstop+) std-style) gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+ Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat May 13 19:57:06 2006 @@ -145,10 +145,10 @@ (defmacro with-children ((win var) &body body) (let ((hwnd (gensym))) `(let ((,var nil)) - (visit-child-widgets ,win #'(lambda (parent child) - (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child ,var))))) + (visit-child-widgets ,win (lambda (parent child) + (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))) + (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) + (push child ,var))))) (setf ,var (reverse ,var)) , at body)))) From junrue at common-lisp.net Sun May 14 04:12:13 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 14 May 2006 00:12:13 -0400 (EDT) Subject: [graphic-forms-cvs] r131 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060514041213.2D77278009@common-lisp.net> Author: junrue Date: Sun May 14 00:12:08 2006 New Revision: 131 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented :callback initarg for control initializer; got the initial focus, IDCANCEL, and IDOK button behaviors working in modal dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun May 14 00:12:08 2006 @@ -183,6 +183,14 @@ @deffn Initarg :image @end deffn @deffn Initarg :style + at table @code + at item :cancel-button + at item :check-box + at item :default-button + at item :push-button + at item :radio-button + at item :toggle-button + at end table @end deffn @deffn Initarg :text @end deffn @@ -742,6 +750,12 @@ Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn + at deffn GenericFunction cancel-widget self +Returns the @ref{widget} that responds to the @sc{esc} key or +otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this +widget must be a @ref{button} and is typically labelled @emph{Cancel}. + at end deffn + @anchor{center-on-owner} @deffn GenericFunction center-on-owner self Position @code{self} such that it is centrally located relative to its Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun May 14 00:12:08 2006 @@ -92,14 +92,14 @@ (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) - #'(lambda () - (if (null flag) - (progn - (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) - (progn - (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun May 14 00:12:08 2006 @@ -139,12 +139,6 @@ (call-next-method) (gfs:dispose dlg)) -(defun btn-callback (disp btn time rect) - (declare (ignore disp time rect)) - (let ((dlg (gfw:parent btn))) - (gfw:show dlg nil) - (gfs:dispose dlg))) - (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -163,15 +157,20 @@ :style '(:vertical)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback #'btn-callback + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback #'btn-callback - :style '(:push-button) + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) + :style '(:cancel-button) :text "Cancel" :parent btn-panel))) + (declare (ignore panel ok-btn cancel-btn)) (gfw:pack dlg) (gfw:center-on-owner dlg) (gfw:show dlg t) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun May 14 00:12:08 2006 @@ -832,6 +832,7 @@ (defconstant +wm-syschar+ #x0106) (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message +(defconstant +wm-initdialog+ #x0110) (defconstant +wm-command+ #x0111) (defconstant +wm-syscommand+ #x0112) (defconstant +wm-timer+ #x0113) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun May 14 00:12:08 2006 @@ -552,6 +552,11 @@ (lparam WPARAM)) (defcfun + ("SetActiveWindow" set-active-window) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun May 14 00:12:08 2006 @@ -49,7 +49,7 @@ (setf std-flags (logior std-flags gfs::+bs-checkbox+))) ((eq sym :default-button) (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) - ((eq sym :push-button) + ((or (eq sym :push-button) (eq sym :cancel-button)) (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) @@ -67,7 +67,13 @@ (gfs:handle parent) std-style ex-style - (increment-widget-id (thread-context))))) + (cond + ((find :default-button (style-of btn)) + gfs::+idok+) + ((find :cancel-button (style-of btn)) + gfs::+idcancel+) + (t + (increment-widget-id (thread-context))))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun May 14 00:12:08 2006 @@ -136,9 +136,12 @@ (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) (error 'gfs:toolkit-error "set-focus failed"))) -(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) - (error 'gfs:disposed-error))) + (error 'gfs:disposed-error)) + (unless (or disp callbacks (not (functionp callback))) + (let ((class (define-dispatcher `((event-select . ,callback))))) + (setf (dispatcher ctrl) (make-instance (class-name class)))))) (defmethod preferred-size :before ((ctrl control) width-hint height-hint) (declare (ignorable width-hint height-hint)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun May 14 00:12:08 2006 @@ -61,9 +61,43 @@ (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) -(defmethod event-close ((self event-dispatcher) (dlg dialog) time) - (declare (ignore time)) - (show dlg nil)) +(defmethod cancel-widget :before ((self dialog)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod cancel-widget ((self dialog)) + (let ((def-widget nil)) + (visit-child-widgets self (lambda (parent kid) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) + gfs::+idcancel+) + (setf def-widget kid)))) + def-widget)) + +(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) + (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) + (error 'gfs:disposed-error))) + +(defmethod (setf cancel-widget) ((cancel-widget widget) (self dialog)) + (when (or (not (typep cancel-widget 'button)) + (and (style-of cancel-widget) + (null (intersection '(:push-button :cancel-button :default-button) + (style-of cancel-widget))))) + (warn 'gfs:toolkit-warning :detail "only push buttons may serve as cancel widgets in a dialog") + (return-from cancel-widget nil)) + (let ((old-widget (cancel-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) + (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (let* ((hwnd (gfs:handle cancel-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logior style gfs::+bs-pushbutton+)) + (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -85,24 +119,31 @@ (defmethod (setf default-widget) ((def-widget widget) (self dialog)) (when (or (not (typep def-widget 'button)) (and (style-of def-widget) - (null (find :push-button (style-of def-widget))))) + (null (intersection '(:push-button :cancel-button :default-button) + (style-of def-widget))))) (warn 'gfs:toolkit-warning :detail "only push buttons may serve as default widgets in a dialog") (return-from default-widget nil)) - (let ((old-def-widget (default-widget self))) - (if old-def-widget - (let* ((hwnd (gfs:handle old-def-widget)) + (let ((old-widget (default-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) (style (gfs::get-window-long hwnd gfs::+gwl-style+))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) (style (gfs::get-window-long hwnd gfs::+gwl-style+))) (setf style (logior style gfs::+bs-defpushbutton+)) + (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address hwnd) 1) (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) +(defmethod gfs:dispose ((self dialog)) + (if (visible-p self) + (show self nil)) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) @@ -121,6 +162,10 @@ ;; (init-window self +dialog-classname+ #'register-dialog-class owner text)) +(defmethod event-close ((self event-dispatcher) (dlg dialog) time) + (declare (ignore time)) + (show dlg nil)) + (defmethod show ((self dialog) flag) (let* ((tc (thread-context)) (hutility (utility-hwnd tc)) @@ -139,7 +184,10 @@ (enable win (null flag)))))) ((and owner-modal owner) (enable owner (null flag)))) - (call-next-method) + (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)) + (let ((focus-hwnd (gfs::get-next-dlg-tab-item hdlg (cffi:null-pointer) 0))) + (unless (gfs:null-handle-p focus-hwnd) + (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address focus-hwnd) 1))) (when (and flag (or app-modal owner-modal)) (message-loop (lambda (gm-code msg-ptr) (cond Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun May 14 00:12:08 2006 @@ -35,7 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:item integer gfs:rectangle)))) + (gfw:event-select . (gfw:event-source integer gfs:rectangle)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -69,8 +69,8 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) - (unless (null callbacks) +(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys) + (unless (or disp (null callbacks)) (let ((class (define-dispatcher callbacks))) (setf (dispatcher self) (make-instance (class-name class)))))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 14 00:12:08 2006 @@ -167,6 +167,13 @@ (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) +#| +(defmethod process-message (hwnd (msg (eql gfs::+wm-initdialog+)) wparam lparam) + (declare (ignore hwnd lparam)) + (format t "WM_INITDIALOG: ~x~%" wparam) + 1) +|# + (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignore hwnd lparam)) (let* ((tc (thread-context)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun May 14 00:12:08 2006 @@ -292,8 +292,7 @@ (error 'gfs:disposed-error))) (defmethod show ((w widget) flag) - (gfs::show-window (gfs:handle w) - (if flag gfs::+sw-showna+ gfs::+sw-hide+))) + (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) (defmethod update :before ((w widget)) (if (gfs:disposed-p w) From junrue at common-lisp.net Tue May 16 05:02:53 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 16 May 2006 01:02:53 -0400 (EDT) Subject: [graphic-forms-cvs] r132 - trunk/src/uitoolkit/widgets Message-ID: <20060516050253.869FB1C00F@common-lisp.net> Author: junrue Date: Tue May 16 01:02:50 2006 New Revision: 132 Modified: trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/window.lisp Log: simplified child visitor function management in preparation for refactoring visit-* functions into map-like functions Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Tue May 16 01:02:50 2006 @@ -56,7 +56,7 @@ (defun visit-displays (func) ;; - ;; supplied closure should expect three parameters: + ;; supplied closure should expect two parameters: ;; display handle ;; flag data ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue May 16 01:02:50 2006 @@ -167,13 +167,6 @@ (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) -#| -(defmethod process-message (hwnd (msg (eql gfs::+wm-initdialog+)) wparam lparam) - (declare (ignore hwnd lparam)) - (format t "WM_INITDIALOG: ~x~%" wparam) - 1) -|# - (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignore hwnd lparam)) (let* ((tc (thread-context)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue May 16 01:02:50 2006 @@ -34,7 +34,7 @@ (in-package #:graphic-forms.uitoolkit.widgets) (defclass thread-context () - ((child-visitor-stack :initform nil) + ((child-visitor-func :initform nil :accessor child-visitor-func) (display-visitor-func :initform nil :accessor display-visitor-func) (image-loaders-by-type :initform (make-hash-table :test #'equal)) (job-table :initform (make-hash-table :test #'equal)) @@ -101,32 +101,22 @@ (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." - (let ((fn (first (slot-value tc 'child-visitor-stack)))) - (if (null fn) - (error 'gfs:toolkit-error :detail "child visitor function stack is empty")) - (funcall fn parent child))) - -(defmethod push-child-visitor-func ((tc thread-context) func) - "Push the supplied closure onto the child window visitor function stack." - (if (not (functionp func)) - (error 'gfs:toolkit-error :detail "function argument required")) - (push func (slot-value tc 'child-visitor-stack)) - nil) - -(defmethod pop-child-visitor-func ((tc thread-context)) - "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." - (pop (slot-value tc 'child-visitor-stack))) + (let ((func (child-visitor-func tc))) + (if func + (funcall func parent child) + (warn 'gfs:toolkit-warning :detail "child visitor function is nil")))) (defmethod call-display-visitor-func ((tc thread-context) hmonitor data) (let ((func (display-visitor-func tc))) - (unless (null func) - (funcall func hmonitor data)))) + (if func + (funcall func hmonitor data) + (warn 'gfs:toolkit-warning :detail "display visitor function is nil")))) (defmethod call-top-level-visitor-func ((tc thread-context) win) (let ((func (top-level-visitor-func tc))) - (unless (null func) - (funcall func win)))) + (if func + (funcall func win) + (warn 'gfs:toolkit-warning :detail "top-level visitor function is nil")))) (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue May 16 01:02:50 2006 @@ -87,7 +87,7 @@ ;; current child widget ;; (let ((tc (thread-context))) - (push-child-visitor-func tc func) + (setf (child-visitor-func tc) func) (unwind-protect #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") @@ -100,7 +100,7 @@ (gfs::enum-child-windows ptr #'child_window_visitor (cffi:pointer-address (gfs:handle win)))) - (pop-child-visitor-func tc))) + (setf (child-visitor-func tc) nil))) nil) (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) From junrue at common-lisp.net Tue May 16 05:17:58 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 16 May 2006 01:17:58 -0400 (EDT) Subject: [graphic-forms-cvs] r133 - trunk Message-ID: <20060516051758.C4E332001B@common-lisp.net> Author: junrue Date: Tue May 16 01:17:57 2006 New Revision: 133 Modified: trunk/README.txt Log: restored known problem item that mentions CLISP bug 1463994 Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue May 16 01:17:57 2006 @@ -47,25 +47,32 @@ features in general that are not yet implemented, this section lists known problems in this release: -1. Image loading currently requires installation of the ImageMagick +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. + +2. 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. -2. The event-tester application's menu definition specifies that the +3. 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. -3. The src/demos/unblocked directory contains a start at a demo +4. 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. -4. The text-extent generic function currently does not return +5. 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. From junrue at common-lisp.net Tue May 16 16:08:55 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 16 May 2006 12:08:55 -0400 (EDT) Subject: [graphic-forms-cvs] r134 - trunk/src/uitoolkit/widgets Message-ID: <20060516160855.0B59D44051@common-lisp.net> Author: junrue Date: Tue May 16 12:08:55 2006 New Revision: 134 Modified: trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced display/top-level/child visit functions with mapcar-like replacements; implemented top-level disabling for :application-modal style Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue May 16 12:08:55 2006 @@ -36,6 +36,8 @@ (defconstant +default-dialog-title+ " ") (defconstant +dlgwindowextra+ 48) +(defvar *disabled-top-levels* nil) + ;;; ;;; helper functions ;;; @@ -66,13 +68,10 @@ (error 'gfs:disposed-error))) (defmethod cancel-widget ((self dialog)) - (let ((def-widget nil)) - (visit-child-widgets self (lambda (parent kid) - (declare (ignore parent)) - (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) - gfs::+idcancel+) - (setf def-widget kid)))) - def-widget)) + (with-children (self kids) + (loop for kid in kids + until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+) + finally (return kid)))) (defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -104,13 +103,10 @@ (error 'gfs:disposed-error))) (defmethod default-widget ((self dialog)) - (let ((def-widget nil)) - (visit-child-widgets self (lambda (parent kid) - (declare (ignore parent)) - (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) - gfs::+idok+) - (setf def-widget kid)))) - def-widget)) + (with-children (self kids) + (loop for kid in kids + until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+) + finally (return kid)))) (defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -174,14 +170,18 @@ (owner (owner self)) (hdlg (gfs:handle self))) (cond - ((and app-modal owner) - ;; FIXME: need to save and restore each window's prior - ;; enabled state - ;; - (visit-top-level-windows (lambda (win) - (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) - (cffi:pointer-eq (gfs:handle win) hutility)) - (enable win (null flag)))))) + ((and app-modal flag) + (setf *disabled-top-levels* nil) + (maptoplevels (lambda (win) + (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) + (cffi:pointer-eq (gfs:handle win) hutility)) + (if (enabled-p win) + (push win *disabled-top-levels*)) + (enable win nil))))) + ((and app-modal (null flag)) + (loop for win in *disabled-top-levels* + do (enable win t)) + (setf *disabled-top-levels* nil)) ((and owner-modal owner) (enable owner (null flag)))) (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Tue May 16 12:08:55 2006 @@ -54,9 +54,9 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -(defun visit-displays (func) +(defun mapdisplays (func) ;; - ;; supplied closure should expect two parameters: + ;; func should expect two parameters: ;; display handle ;; flag data ;; @@ -67,18 +67,18 @@ (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) - (setf (display-visitor-func tc) nil))) - nil) + (setf (display-visitor-func tc) nil)) + (let ((tmp (reverse (display-visitor-results tc)))) + (setf (display-visitor-results tc) nil) + tmp))) (defun obtain-displays () - (let ((display-list nil)) - (visit-displays #'(lambda (hmonitor data) - (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) - gfs::+monitorinfoof-primary+)) - (display (make-instance 'display :handle hmonitor))) - (setf (slot-value display 'primary) pflag) - (push display display-list)))) - display-list)) + (mapdisplays (lambda (hmonitor data) + (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) + gfs::+monitorinfoof-primary+)) + (display (make-instance 'display :handle hmonitor))) + (setf (slot-value display 'primary) pflag) + (push display (display-visitor-results (thread-context))))))) (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) @@ -103,9 +103,9 @@ (call-top-level-visitor-func tc win))) 1) -(defun visit-top-level-windows (func) +(defun maptoplevels (func) ;; - ;; supplied closure should expect one parameter: + ;; func should expect one parameter: ;; top-level window ;; (let ((tc (thread-context))) @@ -117,8 +117,10 @@ #+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) #'top_level_window_visitor 0) - (setf (top-level-visitor-func tc) nil))) - nil) + (setf (top-level-visitor-func tc) nil)) + (let ((tmp (reverse (top-level-visitor-results tc)))) + (setf (top-level-visitor-results tc) nil) + tmp))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue May 16 12:08:55 2006 @@ -34,24 +34,27 @@ (in-package #:graphic-forms.uitoolkit.widgets) (defclass thread-context () - ((child-visitor-func :initform nil :accessor child-visitor-func) - (display-visitor-func :initform nil :accessor display-visitor-func) - (image-loaders-by-type :initform (make-hash-table :test #'equal)) - (job-table :initform (make-hash-table :test #'equal)) - (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) - (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) - (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-widget-id :initform 100 :reader next-widget-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)) - (top-level-visitor-func :initform nil :accessor top-level-visitor-func) - (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + ((child-visitor-func :initform nil :accessor child-visitor-func) + (child-visitor-results :initform nil :accessor child-visitor-results) + (display-visitor-func :initform nil :accessor display-visitor-func) + (display-visitor-results :initform nil :accessor display-visitor-results) + (image-loaders-by-type :initform (make-hash-table :test #'equal)) + (job-table :initform (make-hash-table :test #'equal)) + (job-table-lock :initform nil) + (event-time :initform 0 :accessor event-time) + (virtual-key :initform 0 :accessor virtual-key) + (menuitems-by-id :initform (make-hash-table :test #'equal)) + (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-widget-id :initform 100 :reader next-widget-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)) + (top-level-visitor-func :initform nil :accessor top-level-visitor-func) + (top-level-visitor-results :initform nil :accessor top-level-visitor-results) + (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.")) ;; TODO: change this when CLISP acquires MT support Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue May 16 12:08:55 2006 @@ -80,7 +80,7 @@ (call-child-visitor-func tc parent child))) 1) -(defun visit-child-widgets (win func) +(defun mapchildren (win func) ;; ;; supplied closure should expect two parameters: ;; parent window object @@ -100,8 +100,10 @@ (gfs::enum-child-windows ptr #'child_window_visitor (cffi:pointer-address (gfs:handle win)))) - (setf (child-visitor-func tc) nil))) - nil) + (setf (child-visitor-func tc) nil)) + (let ((tmp (reverse (child-visitor-results tc)))) + (setf (child-visitor-results tc) nil) + tmp))) (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -144,12 +146,12 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) (let ((hwnd (gensym))) - `(let ((,var nil)) - (visit-child-widgets ,win (lambda (parent child) - (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child ,var))))) - (setf ,var (reverse ,var)) + `(let ((,var (mapchildren ,win (lambda (parent child) + (let ((,hwnd (gfs::get-ancestor + (gfs:handle child) + gfs::+ga-parent+))) + (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) + (push child (child-visitor-results (thread-context))))))))) , at body)))) ;;; From junrue at common-lisp.net Tue May 16 16:37:08 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 16 May 2006 12:37:08 -0400 (EDT) Subject: [graphic-forms-cvs] r135 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060516163708.38B5F30FD@common-lisp.net> Author: junrue Date: Tue May 16 12:37:07 2006 New Revision: 135 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: fixed a bug in top-level initialize-instance that interfered with :text initarg; bit more work on re-enabling top-levels when modal dialog is dismissed Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Tue May 16 12:37:07 2006 @@ -80,20 +80,20 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* + :text "Mini Frame" :style '(:miniframe)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) - (setf (gfw:text window) "Mini Frame") (gfw:show window t))) (defun create-palette-win (disp item time rect) (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* + :text "Palette" :style '(:palette)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) - (setf (gfw:text window) "Palette") (gfw:show window t))) (defun open-file-dlg (disp item time rect) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue May 16 12:37:07 2006 @@ -51,6 +51,21 @@ gfs::+color-btnface+ +dlgwindowextra+)) +(defun disable-top-levels (hdlg) + (let ((hutility (utility-hwnd (thread-context)))) + (setf *disabled-top-levels* nil) + (maptoplevels (lambda (win) + (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) + (cffi:pointer-eq (gfs:handle win) hutility)) + (if (enabled-p win) + (push win *disabled-top-levels*)) + (enable win nil)))))) + +(defun reenable-top-levels () + (loop for win in *disabled-top-levels* + do (enable win t)) + (setf *disabled-top-levels* nil)) + ;;; ;;; methods ;;; @@ -136,6 +151,7 @@ (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) (defmethod gfs:dispose ((self dialog)) + (reenable-top-levels) (if (visible-p self) (show self nil)) (call-next-method)) @@ -163,25 +179,15 @@ (show dlg nil)) (defmethod show ((self dialog) flag) - (let* ((tc (thread-context)) - (hutility (utility-hwnd tc)) - (app-modal (find :application-modal (style-of self))) - (owner-modal (find :owner-modal (style-of self))) - (owner (owner self)) - (hdlg (gfs:handle self))) + (let ((app-modal (find :application-modal (style-of self))) + (owner-modal (find :owner-modal (style-of self))) + (owner (owner self)) + (hdlg (gfs:handle self))) (cond ((and app-modal flag) - (setf *disabled-top-levels* nil) - (maptoplevels (lambda (win) - (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) - (cffi:pointer-eq (gfs:handle win) hutility)) - (if (enabled-p win) - (push win *disabled-top-levels*)) - (enable win nil))))) + (disable-top-levels hdlg)) ((and app-modal (null flag)) - (loop for win in *disabled-top-levels* - do (enable win t)) - (setf *disabled-top-levels* nil)) + (reenable-top-levels)) ((and owner-modal owner) (enable owner (null flag)))) (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue May 16 12:37:07 2006 @@ -124,18 +124,18 @@ (remove-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner title &allow-other-keys) +(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) - (if (null title) - (setf title +default-window-title+)) + (if (null text) + (setf text +default-window-title+)) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) (when (find :workspace (style-of win)) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func owner title))) + (init-window win classname register-func owner text))) (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) From junrue at common-lisp.net Thu May 18 03:44:34 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 17 May 2006 23:44:34 -0400 (EDT) Subject: [graphic-forms-cvs] r136 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060518034434.C075016008@common-lisp.net> Author: junrue Date: Wed May 17 23:44:34 2006 New Revision: 136 Modified: trunk/build.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixes for minor issues revealed by testing Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Wed May 17 23:44:34 2006 @@ -45,7 +45,7 @@ (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 *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.1/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed May 17 23:44:34 2006 @@ -40,7 +40,7 @@ (load-foreign-library "msimg32.dll") (defcfun - ("AddFontResourceExA" add-font-resource-ex) + ("AddFontResourceExA" add-font-resource) INT (filename :string) (flags DWORD) @@ -341,9 +341,11 @@ (y2 INT)) (defcfun - ("RemoveFontResourceA" remove-font-resource) + ("RemoveFontResourceExA" remove-font-resource) BOOL - (filename :string)) + (filename :string) + (flags DWORD) + (reserved LPTR)) (defcfun ("RoundRect" round-rect) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Wed May 17 23:44:34 2006 @@ -134,7 +134,7 @@ (defmethod give-focus ((ctrl control)) (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) - (error 'gfs:toolkit-error "set-focus failed"))) + (error 'gfs:win32-error :detail "set-focus failed"))) (defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 17 23:44:34 2006 @@ -181,7 +181,7 @@ (gfs::get-window-long hwnd gfs::+gwl-style+) (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) - (error 'gfs:toolkit-error :detail "adjust-window-rect failed")) + (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) (gfs:size-height new-size) (- gfs::bottom gfs::top)))) new-size)) @@ -217,7 +217,7 @@ (defmethod give-focus ((win window)) (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) - (error 'gfs:toolkit-error "set-focus failed"))) + (error 'gfs:win32-error :detail "set-focus failed"))) (defmethod location ((win window)) (if (gfs:disposed-p win) From junrue at common-lisp.net Thu May 18 19:05:02 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 18 May 2006 15:05:02 -0400 (EDT) Subject: [graphic-forms-cvs] r137 - trunk/src/uitoolkit/widgets Message-ID: <20060518190502.9172863020@common-lisp.net> Author: junrue Date: Thu May 18 15:05:02 2006 New Revision: 137 Modified: trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: avoid z-order change when location or size setf functions are called; override compute-outer-size for panels to simply return the desired client size Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu May 18 15:05:02 2006 @@ -49,6 +49,10 @@ ;;; methods ;;; +(defmethod compute-outer-size ((self panel) desired-client-size) + (declare (ignore self)) + (gfs:copy-size desired-client-size)) + (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu May 18 15:05:02 2006 @@ -202,7 +202,7 @@ (gfs:point-x pnt) (gfs:point-y pnt) 0 0 - gfs::+swp-nosize+)) + (logior gfs::+swp-nosize+ gfs::+swp-nozorder+))) (error 'gfs:win32-error :detail "set-window-pos failed"))) (defmethod owner ((self widget)) @@ -270,21 +270,22 @@ (defmethod size ((w widget)) (client-size w)) -(defmethod (setf size) :before ((sz gfs:size) (w widget)) - (declare (ignore sz)) +(defmethod (setf size) :before ((size gfs:size) (w widget)) + (declare (ignore size)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) -(defmethod (setf size) ((sz gfs:size) (w widget)) +(defmethod (setf size) ((size gfs:size) (w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) (if (zerop (gfs::set-window-pos (gfs:handle w) (cffi:null-pointer) 0 0 - (gfs:size-width sz) - (gfs:size-height sz) - gfs::+swp-nomove+)) - (error 'gfs:win32-error :detail "set-window-pos failed"))) + (gfs:size-width size) + (gfs:size-height size) + (logior gfs::+swp-nomove+ gfs::+swp-nozorder+))) + (error 'gfs:win32-error :detail "set-window-pos failed")) + size) (defmethod show :before ((w widget) flag) (declare (ignore flag)) From junrue at common-lisp.net Sun May 21 02:56:05 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 20 May 2006 22:56:05 -0400 (EDT) Subject: [graphic-forms-cvs] r138 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060521025605.A0FD06303E@common-lisp.net> Author: junrue Date: Sat May 20 22:56:05 2006 New Revision: 138 Modified: trunk/build.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp Log: get rid of defvars that are bound to (cffi:null-pointer) as that causes problems in saved images; updated to 060514 drop of CFFI Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sat May 20 22:56:05 2006 @@ -45,7 +45,7 @@ (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.1/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060514/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Sat May 20 22:56:05 2006 @@ -37,33 +37,19 @@ (use-package :cffi) (pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal)) -(define-foreign-library wsock32 (t (:default "wsock32"))) -(define-foreign-library msvcr71 (t (:default "msvcr71"))) -(define-foreign-library x11 (t (:default "x11"))) -(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) -(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) -(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) -(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) -(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) -(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) -(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) -(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) -(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) -(define-foreign-library core_rl_magick (t (:default "CORE_RL_magick_"))) - -(use-foreign-library wsock32) -(use-foreign-library msvcr71) -(use-foreign-library x11) -(use-foreign-library core_rl_bzlib) -(use-foreign-library core_rl_jbig) -(use-foreign-library core_rl_jpeg) -(use-foreign-library core_rl_lcms) -(use-foreign-library core_rl_zlib) -(use-foreign-library core_rl_png) -(use-foreign-library core_rl_tiff) -(use-foreign-library core_rl_ttf) -(use-foreign-library core_rl_xlib) -(use-foreign-library core_rl_magick) +(load-foreign-library "wsock32.dll") +(load-foreign-library "msvcr71.dll") +(load-foreign-library "x11.dll") +(load-foreign-library "CORE_RL_bzlib_.dll") +(load-foreign-library "CORE_RL_jbig_.dll") +(load-foreign-library "CORE_RL_jpeg_.dll") +(load-foreign-library "CORE_RL_lcms_.dll") +(load-foreign-library "CORE_RL_zlib_.dll") +(load-foreign-library "CORE_RL_png_.dll") +(load-foreign-library "CORE_RL_tiff_.dll") +(load-foreign-library "CORE_RL_ttf_.dll") +(load-foreign-library "CORE_RL_xlib_.dll") +(load-foreign-library "CORE_RL_magick_.dll") ;;; ;;; translated from constitute.h Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat May 20 22:56:05 2006 @@ -33,14 +33,6 @@ (in-package :graphic-forms.uitoolkit.system) -;;; -;;; The following variables are used with set-window-pos -;;; -(defvar *hwnd-top* (cffi:null-pointer)) -(defvar *hwnd-bottom* (cffi:make-pointer #x00000001)) -(defvar *hwnd-topmost* (cffi:make-pointer #xFFFFFFFF)) -(defvar *hwnd-notopmost* (cffi:make-pointer #xFFFFFFFE)) - (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sat May 20 22:56:05 2006 @@ -82,8 +82,7 @@ (hwnd-after (cffi:null-pointer)) (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) - (setf hwnd-after gfs::*hwnd-top* - flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) + (setf flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) (if (gfs:null-handle-p hdwp) (gfs::set-window-pos (gfs:handle kid-win) hwnd-after From junrue at common-lisp.net Tue May 23 02:53:08 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 22 May 2006 22:53:08 -0400 (EDT) Subject: [graphic-forms-cvs] r139 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060523025308.B3F4F431B7@common-lisp.net> Author: junrue Date: Mon May 22 22:53:07 2006 New Revision: 139 Added: trunk/src/tests/uitoolkit/widget-unit-tests.lisp Modified: trunk/config.lisp trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored minimum/maximum-size slots so that both windows and controls have this feature Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon May 22 22:53:07 2006 @@ -40,7 +40,7 @@ (in-package #:graphic-forms-system) (defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-0.9.0/") +(defvar *cffi-dir* "cffi-060514/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon May 22 22:53:07 2006 @@ -863,13 +863,14 @@ @end deffn @anchor{maximum-size} - at deffn GenericFunction maximum-size self + at deffn GenericFunction maximum-size self => size Returns a @ref{size} object describing the largest dimensions to which -the user may resize this widget; by default returns @sc{nil}, -indicating that there is effectively no constraint. The corresponding - at sc{setf} function sets this value; if the new maximum size is -smaller than the current size, the widget is resized to the new -maximum. @xref{minimum-size}. +the user may resize this widget. By default, @ref{window}s and + at ref{control}s return @sc{nil} indicating that there is effectively no +constraint.@*@* +The corresponding @sc{setf} function sets this value; +if the new maximum size is smaller than the current size, the widget +is resized to the new maximum. @xref{minimum-size}. @end deffn @deffn GenericFunction menu-bar self @@ -877,13 +878,16 @@ @end deffn @anchor{minimum-size} - at deffn GenericFunction minimum-size self + at deffn GenericFunction minimum-size self => size Returns a @ref{size} object describing the smallest dimensions to -which the user may resize this widget; by default returns @sc{nil}, -indicating that the minimum constraint is determined by the windowing -system's configuration. The corresponding @sc{setf} function sets -this value; if the new minimum size is larger than the current size, -the widget is resized to the new minimum. @xref{maximum-size}. +which the user may resize this widget. By default, @ref{window} +objects return @sc{nil} indicating that the minimum constraint is +determined by the windowing system's configuration; whereas, + at ref{control}s return the same value by default as would + at ref{preferred-size}.@*@* +The corresponding @sc{setf} function sets this value; if the new +minimum size is larger than the current size, the widget is resized to +the new minimum. @xref{maximum-size}. @end deffn @deffn GenericFunction object-to-display self pnt Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon May 22 22:53:07 2006 @@ -77,6 +77,7 @@ (:file "graphics-context-unit-tests") (:file "image-unit-tests") (:file "layout-unit-tests") + (:file "widget-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester") Added: trunk/src/tests/uitoolkit/widget-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/widget-unit-tests.lisp Mon May 22 22:53:07 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; widget-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(define-test class-registration-test + (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class) + (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class) + (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class) + (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class)) + +(define-test repeat-class-registration-test + (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class) + (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class) + (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class) + (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon May 22 22:53:07 2006 @@ -143,9 +143,25 @@ (let ((class (define-dispatcher `((event-select . ,callback))))) (setf (dispatcher ctrl) (make-instance (class-name class)))))) -(defmethod preferred-size :before ((ctrl control) width-hint height-hint) +(defmethod (setf maximum-size) :after (max-size (self control)) + (unless (gfs:disposed-p self) + (let ((size (constrain-new-size max-size (size self) #'min))) + (setf (size self) size)))) + +(defmethod minimum-size :after ((self control)) + (let ((size (slot-value self 'minimum-size))) + (if (null size) + (preferred-size self -1 -1) + size))) + +(defmethod (setf minimum-size) :after (min-size (self control)) + (unless (gfs:disposed-p self) + (let ((size (constrain-new-size min-size (size self) #'max))) + (setf (size self) size)))) + +(defmethod preferred-size :before ((self control) width-hint height-hint) (declare (ignorable width-hint height-hint)) - (if (gfs:disposed-p ctrl) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) (defmethod print-object ((self control) stream) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon May 22 22:53:07 2006 @@ -51,11 +51,6 @@ gfs::+cs-dblclks+ -1)) -(defun constrain-new-size (new-size current-size compare-fn) - (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) - (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) - (gfs:make-size :width new-width :height new-height))) - ;;; ;;; methods ;;; @@ -150,12 +145,6 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) -(defmethod (setf maximum-size) :after (max-size (win top-level)) - (unless (or (gfs:disposed-p win) (null (layout-of win))) - (let ((size (constrain-new-size max-size (size win) #'min))) - (setf (size win) size) - (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) - (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) (if (gfs:disposed-p win) @@ -172,12 +161,6 @@ (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) -(defmethod (setf minimum-size) :after (min-size (win top-level)) - (unless (or (gfs:disposed-p win) (null (layout-of win))) - (let ((size (constrain-new-size min-size (size win) #'max))) - (setf (size win) size) - (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) - (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon May 22 22:53:07 2006 @@ -84,6 +84,14 @@ :initform nil) (pixel-point :accessor pixel-point-of + :initform nil) + (maximum-size + :accessor maximum-size + :initarg :maximum-size + :initform nil) + (minimum-size + :accessor minimum-size + :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -116,6 +124,14 @@ (layout :accessor layout-of :initarg :layout + :initform nil) + (maximum-size + :accessor maximum-size + :initarg :maximum-size + :initform nil) + (minimum-size + :accessor minimum-size + :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) @@ -128,15 +144,7 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) - ((maximum-size - :accessor maximum-size - :initarg :maximum-size - :initform nil) - (minimum-size - :accessor minimum-size - :initarg :minimum-size - :initform nil)) +(defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) (defclass timer (event-source) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon May 22 22:53:07 2006 @@ -168,3 +168,8 @@ (cffi:lisp-string-to-foreign tmp-str (cffi:make-pointer curr-addr) str-len) (incf curr-addr str-len))) buffer)) + +(defun constrain-new-size (new-size current-size compare-fn) + (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) + (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) + (gfs:make-size :width new-width :height new-height))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon May 22 22:53:07 2006 @@ -114,12 +114,10 @@ gfs::hicon gfs::hcursor gfs::hbrush gfs::menuname gfs::classname gfs::smallicon) wc-ptr gfs::wndclassex) - ;; FIXME: move this if form outside of with-foreign-slots - ;; + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) (if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) (progn - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) @@ -226,22 +224,41 @@ (outer-location win pnt) pnt)) -(defmethod layout ((win window)) - (unless (null (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) - -(defmethod pack ((win window)) - (unless (null (layout-of win)) - (perform (layout-of win) win -1 -1)) +(defmethod layout ((self window)) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + +(defmethod (setf maximum-size) :after (max-size (self window)) + (unless (or (gfs:disposed-p self) (null (layout-of self))) + (let ((size (constrain-new-size max-size (size self) #'min))) + (setf (size self) size) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + size))) + +(defmethod (setf minimum-size) :after (min-size (self window)) + (unless (or (gfs:disposed-p self) (null (layout-of self))) + (let ((size (constrain-new-size min-size (size self) #'max))) + (setf (size self) size) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + size))) + +(defmethod pack ((self window)) + (unless (null (layout-of self)) + (perform (layout-of self) self -1 -1)) (call-next-method)) -(defmethod preferred-size ((win window) width-hint height-hint) - (let ((layout (layout-of win))) - (if (and (layout-p win) layout) - (let ((new-client-sz (compute-size layout win width-hint height-hint))) - (compute-outer-size win new-client-sz)) - (size win)))) +(defmethod preferred-size :before ((self window) width-hint height-hint) + (declare (ignorable width-hint height-hint)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod preferred-size ((self window) width-hint height-hint) + (let ((layout (layout-of self))) + (if (and (layout-p self) layout) + (let ((new-client-sz (compute-size layout self width-hint height-hint))) + (compute-outer-size self new-client-sz)) + (size self)))) (defmethod print-object ((self window) stream) (print-unreadable-object (self stream :type t) @@ -249,21 +266,21 @@ (format stream "dispatcher: ~a " (dispatcher self)) (format stream "size: ~a" (size self)))) -(defmethod show ((win window) flag) +(defmethod show ((self window) flag) (declare (ignore flag)) (call-next-method) - (gfs::update-window (gfs:handle win))) + (gfs::update-window (gfs:handle self))) -(defmethod size ((win window)) +(defmethod size ((self window)) (let ((sz (gfs:make-size))) - (outer-size win sz) + (outer-size self sz) sz)) -(defmethod window->display :before ((self top-level)) +(defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod window->display ((self top-level)) +(defmethod window->display ((self window)) (let* ((hmonitor (gfs::monitor-from-window (gfs:handle self) gfs::+monitor-defaulttonearest+)) (display (make-instance 'display))) (setf (slot-value display 'gfs:handle) hmonitor) From junrue at common-lisp.net Tue May 23 03:59:49 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 22 May 2006 23:59:49 -0400 (EDT) Subject: [graphic-forms-cvs] r140 - in trunk: docs/manual src/uitoolkit/widgets Message-ID: <20060523035949.22B6C7C017@common-lisp.net> Author: junrue Date: Mon May 22 23:59:48 2006 New Revision: 140 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: defined new generic function text-baseline; implemented it for labels Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon May 22 23:59:48 2006 @@ -980,8 +980,22 @@ parent's coordinate system. @end deffn - at deffn GenericFunction text self -Returns the object's text. + at deffn GenericFunction text self => string +For a @ref{window} or @ref{dialog}, this function returns @code{self}'s +titlebar text (which may be blank). For other @ref{widget}s that have a text +component, this function returns that text component. For anything else, +this function returns @sc{nil}. + at end deffn + + at deffn GenericFunction text-baseline self => integer +Returns the y coordinate value (relative to the top of the @code{self}'s +bounding box) that correlates to the baseline of the text of the + at ref{control}, if any. For controls in which a text baseline is not +meaningful, such as a @ref{label} with an @ref{image}, this function +returns the control's height.@*@* +By default, the library does not implement this function for @ref{window} +subclasses. However, custom controls should implement this function if +the custom control will be managed by a @ref{layout-manager}. @end deffn @deffn GenericFunction update self @@ -1138,7 +1152,13 @@ @deftp Class graphics-context This subclass of @ref{native-object} wraps a native device context, hence instances of this class are used to perform drawing operations. -One normally obtains a graphics-context via @ref{event-paint}. +One normally obtains a graphics-context via @ref{event-paint}; however, +initargs are also available for creating a context associated with an + at ref{image} or a @ref{widget}. + at deffn Initarg :image +This initarg associates the context with an image, +thus allowing applications to draw on the image. + at end deffn @anchor{miter-limit} @deffn Accessor miter-limit This accessor accepts or returns a floating point value that @@ -1210,6 +1230,11 @@ value is 0, which translates to a 1 pixel-wide line drawn with an optimized drawing algorithm. @end deffn + at deffn Initarg :widget +This initarg associates the context with a widget, +thus allowing applications to query graphics-related +attributes of the widget. + at end deffn @end deftp @anchor{image} Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon May 22 23:59:48 2006 @@ -33,6 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +horizontal-button-text-margin+ 7) +(defconstant +vertical-button-text-margin+ 5) + ;;; ;;; methods ;;; @@ -81,18 +84,20 @@ (setf (slot-value btn 'gfs:handle) hwnd))) (init-control btn)) -(defmethod preferred-size ((btn button) width-hint height-hint) - (let ((sz (widget-text-size btn gfs::+dt-singleline+))) +(defmethod preferred-size ((self button) width-hint height-hint) + (let ((size (widget-text-size self gfs::+dt-singleline+))) (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint) - (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) + (setf (gfs:size-width size) width-hint) + (setf (gfs:size-width size) (+ (gfs:size-width size) + (* +horizontal-button-text-margin+ 2)))) (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint) - (setf (gfs:size-height sz) (+ (gfs:size-height sz) 10))) - sz)) + (setf (gfs:size-height size) height-hint) + (setf (gfs:size-height size) (+ (gfs:size-height size) + ( * +vertical-button-text-margin+ 2)))) + size)) -(defmethod text ((btn button)) - (get-widget-text btn)) +(defmethod text ((self button)) + (get-widget-text self)) -(defmethod (setf text) (str (btn button)) - (set-widget-text btn str)) +(defmethod (setf text) (str (self button)) + (set-widget-text self str)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon May 22 23:59:48 2006 @@ -100,48 +100,57 @@ (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) -(defmethod gfg:font ((ctrl control)) - (font-of ctrl)) +(defmethod gfg:font ((self control)) + (let ((font (font-of self))) + (unless font + (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0))) + (if (zerop result) + (let ((gc (make-instance 'gfg:graphics-context :widget self))) + (unwind-protect + (setf font (gfg:font gc))) + (gfs:dispose gc)) + (setf font (make-instance 'gfg:font :handle (cffi:make-pointer result)))))) + font)) -(defmethod (setf gfg:font) :before (font (ctrl control)) +(defmethod (setf gfg:font) :before (font (self control)) (declare (ignore color)) - (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font)) + (if (or (gfs:disposed-p self) (gfs:disposed-p font)) (error 'gfs:disposed-error))) -(defmethod (setf gfg:font) (font (ctrl control)) - (setf (font-of ctrl) font) - (redraw ctrl)) +(defmethod (setf gfg:font) (font (self control)) + (setf (font-of self) font) + (redraw self)) -(defmethod gfg:foreground-color :before ((ctrl control)) - (if (gfs:disposed-p ctrl) +(defmethod gfg:foreground-color :before ((self control)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod gfg:foreground-color ((ctrl control)) - (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+)))) +(defmethod gfg:foreground-color ((self control)) + (or (text-color-of self) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+)))) -(defmethod (setf gfg:foreground-color) :before (color (ctrl control)) +(defmethod (setf gfg:foreground-color) :before (color (self control)) (declare (ignore color)) - (if (gfs:disposed-p ctrl) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf gfg:foreground-color) (color (ctrl control)) - (setf (text-color-of ctrl) (gfg:copy-color color)) - (redraw ctrl)) +(defmethod (setf gfg:foreground-color) (color (self control)) + (setf (text-color-of self) (gfg:copy-color color)) + (redraw self)) -(defmethod give-focus :before ((ctrl control)) - (if (gfs:disposed-p ctrl) +(defmethod give-focus :before ((self control)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod give-focus ((ctrl control)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) +(defmethod give-focus ((self control)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle self))) (error 'gfs:win32-error :detail "set-focus failed"))) -(defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys) +(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) (unless (or disp callbacks (not (functionp callback))) (let ((class (define-dispatcher `((event-select . ,callback))))) - (setf (dispatcher ctrl) (make-instance (class-name class)))))) + (setf (dispatcher self) (make-instance (class-name class)))))) (defmethod (setf maximum-size) :after (max-size (self control)) (unless (gfs:disposed-p self) @@ -168,4 +177,8 @@ (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) + (format stream "size: ~a " (size self)) + (format stream "text baseline: ~a" (text-baseline self)))) + +(defmethod text-baseline ((self control)) + (gfs:size-height (size self))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon May 22 23:59:48 2006 @@ -175,7 +175,7 @@ (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) (sz nil)) - (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit + (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) (let ((image (image label))) (if image (gfg:size image) @@ -208,3 +208,16 @@ gfs::+ws-child+ gfs::+ws-visible+)))) (set-widget-text label str)) + +(defmethod text-baseline ((self label)) + (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) + gfs::+ss-bitmap+) + gfs::+ss-bitmap+) + (let ((image (image self))) + (if image + (gfs:size-height (gfg:size image)) + 0)) + (let* ((font (font self)) + (gc (make-instance 'gfg:graphics-context :widget self)) + (b-width (border-width self))) + (+ b-width (gfg:ascent (gfg:metrics gc font)))))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon May 22 23:59:48 2006 @@ -330,6 +330,9 @@ (defgeneric text (self) (:documentation "Returns the object's text.")) +(defgeneric text-baseline (self) + (:documentation "Returns the y coordinate of the object's text component, if any.")) + (defgeneric text-height (self) (:documentation "Returns the height of the object's text field.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon May 22 23:59:48 2006 @@ -295,6 +295,10 @@ (defmethod show ((w widget) flag) (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) +(defmethod text-baseline :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod update :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) From junrue at common-lisp.net Tue May 23 04:23:19 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 23 May 2006 00:23:19 -0400 (EDT) Subject: [graphic-forms-cvs] r141 - trunk/src/uitoolkit/widgets Message-ID: <20060523042319.98B104610C@common-lisp.net> Author: junrue Date: Tue May 23 00:23:19 2006 New Revision: 141 Modified: trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp Log: implemented text-baseline for buttons Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue May 23 00:23:19 2006 @@ -101,3 +101,8 @@ (defmethod (setf text) (str (self button)) (set-widget-text self str)) + +(defmethod text-baseline ((self button)) + (let ((font (gfg:font self)) + (gc (make-instance 'gfg:graphics-context :widget self))) + (+ +vertical-button-text-margin+ (gfg:ascent (gfg:metrics gc font))))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue May 23 00:23:19 2006 @@ -217,7 +217,7 @@ (if image (gfs:size-height (gfg:size image)) 0)) - (let* ((font (font self)) - (gc (make-instance 'gfg:graphics-context :widget self)) - (b-width (border-width self))) + (let ((font (gfg:font self)) + (gc (make-instance 'gfg:graphics-context :widget self)) + (b-width (border-width self))) (+ b-width (gfg:ascent (gfg:metrics gc font))))))