[graphic-forms-cvs] r124 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu May 11 01:21:50 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list