- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r126 - in trunk: docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

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 -@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. +@anchor{default-message-filter} +@deffn Function default-message-filter gm-code msg-ptr +Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and +@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 +@sc{t} is returned so that @ref{message-loop} will +exit. @code{gm-code} is zero when @code{msg-ptr} identifies a +@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}. +@end deffn + +@anchor{dialog-message-filter} +@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. +@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 +@anchor{message-loop} +@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 +@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 +@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: +@itemize @bullet +@item @ref{default-message-filter} +@item @ref{dialog-message-filter} +@end itemize +@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)

1 0

[graphic-forms-cvs] r125 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

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))

1 0

[graphic-forms-cvs] r124 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

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)

1 0

[graphic-forms-cvs] r123 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 May '06

10 May '06

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 +@ref{window}. @end deftp @anchor{display} @@ -236,7 +237,7 @@ @end deftp @anchor{file-dialog} -@deftp Class file-dialog +@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 +@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 +@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 +@anchor{file-dialog-paths} +@deffn Function file-dialog-paths dlg +Interrogates the data structure associated with an instance of +@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. +@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 +@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 +@anchor{with-file-dialog} +@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}. +@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)) + ,@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)

1 0

[graphic-forms-cvs] r122 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 07 May '06

07 May '06

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)))

1 0

[graphic-forms-cvs] r121 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 07 May '06

07 May '06

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"))

1 0

[graphic-forms-cvs] r120 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 07 May '06

07 May '06

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

1 0

[graphic-forms-cvs] r119 - trunk/src/demos/unblocked
by junrue＠common-lisp.net 06 May '06

06 May '06

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*))

1 0

[graphic-forms-cvs] r118 - in trunk: docs/manual src src/uitoolkit/widgets
by junrue＠common-lisp.net 05 May '06

05 May '06

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 +@deffn GenericFunction append-separator self +Adds a separator item to the object, and returns the newly-created +item. +@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."))

1 0

[graphic-forms-cvs] r117 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 04 May '06

04 May '06

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

1 0