[graphic-forms-cvs] r46 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Mar 17 05:42:12 UTC 2006
Author: junrue
Date: Fri Mar 17 00:42:11 2006
New Revision: 46
Added:
trunk/src/uitoolkit/widgets/panel.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/mock-objects.lisp
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/text-label.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 window class to differentiate between top-level and panel windows; replaced realize generic function by moving native object creation into initialize-instance
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Fri Mar 17 00:42:11 2006
@@ -107,5 +107,7 @@
(:file "menu-language")
(:file "event")
(:file "window")
+ (:file "top-level")
+ (:file "panel")
(:file "layout")
(:file "flow-layout")))))))))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Mar 17 00:42:11 2006
@@ -91,7 +91,6 @@
;; classes and structs
;; constants
- #:+button-classname+
;; methods, functions, macros
#:detail
@@ -230,6 +229,8 @@
#:layout-manager
#:menu
#:menu-item
+ #:panel
+ #:top-level
#:widget
#:widget-with-items
#:window
@@ -423,7 +424,6 @@
#:paste
#:peer
#:preferred-size
- #:realize
#:redraw
#:redrawing-p
#:remove-all
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Fri Mar 17 00:42:11 2006
@@ -190,8 +190,8 @@
(let ((echo-md (make-instance 'event-tester-echo-dispatcher))
(exit-md (make-instance 'event-tester-exit-dispatcher))
(menubar nil))
- (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events)))
- (gfw:realize *event-tester-window* nil :style-workspace)
+ (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events)
+ :style '(:style-workspace)))
(setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md
:submenu ((:item "&Open..." :dispatcher echo-md)
(:item "&Save..." :disabled :dispatcher echo-md)
Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp (original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 17 00:42:11 2006
@@ -60,8 +60,8 @@
(defun run-hello-world-internal ()
(let ((menubar nil))
- (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events)))
- (gfw:realize *hello-win* nil :style-workspace)
+ (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events)
+ :style '(:style-workspace)))
(setf menubar (gfw:defmenusystem ((:item "&File"
:submenu ((:item "E&xit" :callback #'exit-fn))))))
(setf (gfw:menu-bar *hello-win*) menubar)
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Mar 17 00:42:11 2006
@@ -70,9 +70,19 @@
:initarg :id
:initform 0)))
+(defclass test-panel (gfw:panel) ())
+
+(defmethod gfw:preferred-size ((win test-panel) width-hint height-hint)
+ (declare (ignore width-hint height-hint))
+ (gfi:make-size :width 45 :height 45))
+
+(defmethod gfw:text ((win test-panel))
+ (declare (ignore win))
+ "Test Panel")
+
(defun add-layout-tester-widget (widget-class subtype)
(let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*))
- (w (make-instance widget-class :dispatcher be)))
+ (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be)))
(cond
((eql subtype :push-button)
(setf (toggle-fn be) (let ((flag nil))
@@ -83,11 +93,10 @@
(format nil "~d ~a" (id be) +btn-text-before+))
(progn
(setf flag nil)
- (format nil "~d ~a" (id be) +btn-text-after+)))))))
+ (format nil "~d ~a" (id be) +btn-text-after+))))))
+ (setf (gfw:text w) (funcall (toggle-fn be))))
((eql subtype :text-label)
- (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+)))))
- (gfw:realize w *layout-tester-win* subtype)
- (setf (gfw:text w) (funcall (toggle-fn be)))
+ (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))))
(incf *widget-counter*)))
(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
@@ -331,23 +340,26 @@
(let ((menubar nil)
(pack-disp (make-instance 'pack-layout-dispatcher))
(add-btn-disp (make-instance 'add-child-dispatcher))
+ (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel
+ :subtype :panel))
(add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label
:subtype :text-label))
(rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher))
(vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher
:check-test-fn #'gfw:visible-p)))
- (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
- :layout (make-instance 'gfw:flow-layout
- :spacing +spacing-delta+
- :margins +margin-delta+)))
- (gfw:realize *layout-tester-win* nil :style-workspace)
+ (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events)
+ :style '(:style-workspace)
+ :layout (make-instance 'gfw:flow-layout
+ :spacing +spacing-delta+
+ :margins +margin-delta+)))
(setf menubar (gfw:defmenusystem ((:item "&File"
:submenu ((:item "E&xit"
:callback #'exit-layout-callback)))
(:item "&Children"
:submenu ((:item "Add"
:submenu ((:item "Button" :dispatcher add-btn-disp)
- (:item "Label" :dispatcher add-text-label-disp)))
+ (:item "Label" :dispatcher add-text-label-disp)
+ (:item "Panel" :dispatcher add-panel-disp)))
(:item "Remove" :dispatcher rem-menu-disp
:submenu ((:item "")))
(:item "Visible" :dispatcher vis-menu-disp
Modified: trunk/src/tests/uitoolkit/mock-objects.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/mock-objects.lisp (original)
+++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Mar 17 00:42:11 2006
@@ -57,7 +57,7 @@
:initarg :min-size
:initform (gfi:make-size))))
-(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys)
+(defmethod initialize-instance :after ((widget mock-widget) &key)
(setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF)))
(defmethod gfw:minimum-size ((widget mock-widget))
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 17 00:42:11 2006
@@ -66,16 +66,18 @@
(defun create-borderless-win (disp item time rect)
(declare (ignore disp item time rect))
- (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events))))
- (gfw:realize window *main-win* :style-borderless)
+ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events)
+ :owner *main-win*
+ :style '(:style-borderless))))
(setf (gfw:location window) (gfi:make-point :x 400 :y 250))
(setf (gfw:size window) (gfi:make-size :width 300 :height 250))
(gfw:show window t)))
(defun create-miniframe-win (disp item time rect)
(declare (ignore disp item time rect))
- (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events))))
- (gfw:realize window *main-win* :style-miniframe)
+ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
+ :owner *main-win*
+ :style '(:style-miniframe))))
(setf (gfw:location window) (gfi:make-point :x 250 :y 150))
(setf (gfw:size window) (gfi:make-size :width 150 :height 225))
(setf (gfw:text window) "Mini Frame")
@@ -83,8 +85,9 @@
(defun create-palette-win (disp item time rect)
(declare (ignore disp item time rect))
- (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events))))
- (gfw:realize window *main-win* :style-palette)
+ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
+ :owner *main-win*
+ :style '(:style-palette))))
(setf (gfw:location window) (gfi:make-point :x 250 :y 150))
(setf (gfw:size window) (gfi:make-size :width 150 :height 225))
(setf (gfw:text window) "Palette")
@@ -98,8 +101,8 @@
(defun run-windlg-internal ()
(let ((menubar nil))
- (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events)))
- (gfw:realize *main-win* nil :style-workspace)
+ (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events)
+ :style '(:style-workspace)))
(setf menubar (gfw:defmenusystem ((:item "&File"
:submenu ((:item "E&xit" :callback #'exit-callback)))
(:item "&Windows"
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 17 00:42:11 2006
@@ -232,11 +232,6 @@
(defconstant +mfs-disabled+ #x00000003)
(defconstant +mfs-checked+ #x00000008)
(defconstant +mfs-hilite+ #x00000080)
-(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h
-(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h
-(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h
-(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h
-(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h
(defconstant +mfs-enabled+ #x00000000)
(defconstant +mfs-unchecked+ #x00000000)
(defconstant +mfs-unhilite+ #x00000000)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 17 00:42:11 2006
@@ -61,6 +61,21 @@
(setf std-flags gfs::+bs-pushbox+))))
(values std-flags ex-flags)))
+(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys)
+ (if (not (listp style))
+ (setf style (list style)))
+ (multiple-value-bind (std-style ex-style)
+ (compute-style-flags btn style)
+ (let ((hwnd (create-window gfs::+button-classname+
+ " "
+ (gfi:handle parent)
+ (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
+ ex-style)))
+ (if (not hwnd)
+ (error 'gfs:win32-error :detail "create-window failed"))
+ (setf (slot-value btn 'gfi:handle) hwnd)))
+ (init-control btn))
+
(defmethod preferred-size ((btn button) width-hint height-hint)
(let ((sz (widget-text-size btn gfs::+dt-singleline+ 0)))
(if (>= width-hint 0)
@@ -71,18 +86,6 @@
(setf (gfi:size-height sz) (+ (gfi:size-height sz) 10)))
sz))
-(defmethod realize ((btn button) parent &rest style)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags btn style)
- (let ((hwnd (create-window gfs:+button-classname+
- " "
- (gfi:handle parent)
- (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
- ex-style)))
- (if (not hwnd)
- (error 'gfs:win32-error :detail "create-window failed"))
- (setf (slot-value btn 'gfi:handle) hwnd))))
-
(defmethod text ((btn button))
(get-widget-text btn))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Fri Mar 17 00:42:11 2006
@@ -34,30 +34,30 @@
(in-package :graphic-forms.uitoolkit.widgets)
;;;
-;;; methods
+;;; helper functions
;;;
-(defmethod preferred-size :before ((ctl control) width-hint height-hint)
- (declare (ignorable width-hint height-hint))
- (if (gfi:disposed-p ctl)
- (error 'gfi:disposed-error)))
-
-(defmethod realize :before ((ctl control) parent &rest style)
- (declare (ignore style))
- (if (gfi:disposed-p parent)
- (error 'gfi:disposed-error))
- (if (not (gfi:disposed-p ctl))
- (error 'gfs:toolkit-error :detail "object already realized")))
-
-(defmethod realize :after ((ctl control) parent &rest style)
- (declare (ignorable parent style))
- (let ((hwnd (gfi:handle ctl)))
+(defun init-control (ctrl)
+ (let ((hwnd (gfi:handle ctrl)))
(subclass-wndproc hwnd)
- (put-widget (thread-context) ctl)
+ (put-widget (thread-context) ctrl)
(let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
(unless (gfi:null-handle-p hfont)
(unless (zerop (gfs::send-message hwnd
- gfs::+wm-setfont+
- (cffi:pointer-address hfont)
- 0))
+ gfs::+wm-setfont+
+ (cffi:pointer-address hfont)
+ 0))
(error 'gfs:win32-error :detail "send-message failed"))))))
+
+;;;
+;;; methods
+;;;
+
+(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys)
+ (if (gfi:disposed-p parent)
+ (error 'gfi:disposed-error)))
+
+(defmethod preferred-size :before ((ctrl control) width-hint height-hint)
+ (declare (ignorable width-hint height-hint))
+ (if (gfi:disposed-p ctrl)
+ (error 'gfi:disposed-error)))
Added: trunk/src/uitoolkit/widgets/panel.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 17 00:42:11 2006
@@ -0,0 +1,71 @@
+;;;;
+;;;; panel.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.widgets)
+
+(defconstant +panel-window-classname+ "GraphicFormsPanel")
+
+;;;
+;;; helper functions
+;;;
+
+(defun register-panel-window-class ()
+ (register-window-class +panel-window-classname+
+ (cffi:get-callback 'uit_widgets_wndproc)
+ gfs::+cs-dblclks+
+ gfs::+color-btnface+))
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((win panel) &rest style)
+ (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))
+ (ex-flags 0))
+ (mapc #'(lambda (sym)
+ (cond
+ ;; styles that can be combined
+ ;;
+ ((eq sym :style-border)
+ (setf std-flags (logior std-flags gfs::+ws-border+)))))
+ (flatten style))
+ (values std-flags ex-flags)))
+
+(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys)
+ (if (null parent)
+ (error 'gfs:toolkit-error :detail "parent is required for panel"))
+ (if (gfi:disposed-p parent)
+ (error 'gfi:disposed-error))
+ (if (not (listp style))
+ (setf style (list style)))
+ (init-window win +panel-window-classname+ #'register-panel-window-class style parent ""))
Modified: trunk/src/uitoolkit/widgets/text-label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/text-label.lisp (original)
+++ trunk/src/uitoolkit/widgets/text-label.lisp Fri Mar 17 00:42:11 2006
@@ -72,6 +72,22 @@
(setf std-flags (logior std-flags gfs::+ss-left+)))))
(values std-flags ex-flags)))
+(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys)
+ (if (not (listp style))
+ (setf style (list style)))
+ (multiple-value-bind (std-style ex-style)
+ (compute-style-flags label style)
+ (let ((hwnd (create-window gfs::+static-classname+
+ " "
+ (gfi:handle parent)
+ (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
+ ex-style)))
+ (if (not hwnd)
+ (error 'gfs:win32-error :detail "create-window failed"))
+ (setf (slot-value label 'gfi:handle) hwnd)))
+ (init-control label))
+
+
(defmethod preferred-size ((label text-label) width-hint height-hint)
(let* ((hwnd (gfi:handle label))
(bits (gfs::get-window-long hwnd gfs::+gwl-style+))
@@ -90,18 +106,6 @@
(incf (gfi:size-height sz) (* b-width 2))
sz))
-(defmethod realize ((label text-label) parent &rest style)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags label style)
- (let ((hwnd (create-window gfs::+static-classname+
- " "
- (gfi:handle parent)
- (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
- ex-style)))
- (if (not hwnd)
- (error 'gfs:win32-error :detail "create-window failed"))
- (setf (slot-value label 'gfi:handle) hwnd))))
-
(defmethod text ((label text-label))
(get-widget-text label))
Added: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Fri Mar 17 00:42:11 2006
@@ -0,0 +1,172 @@
+;;;;
+;;;; top-level.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.widgets)
+
+(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel")
+
+(defconstant +default-window-title+ "New Window")
+
+;;;
+;;; helper functions
+;;;
+
+(defun register-toplevel-window-class ()
+ (register-window-class +toplevel-window-classname+
+ (cffi:get-callback 'uit_widgets_wndproc)
+ gfs::+cs-dblclks+
+ gfs::+color-appworkspace+))
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((win top-level) &rest style)
+ (declare (ignore win))
+ (let ((std-flags 0)
+ (ex-flags 0))
+ (mapc #'(lambda (sym)
+ (cond
+ ;; styles that can be combined
+ ;;
+#|
+ ((eq sym :style-hscroll)
+ (setf std-flags (logior std-flags gfs::+ws-hscroll+)))
+ ((eq sym :style-max)
+ (setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
+ ((eq sym :style-min)
+ (setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
+ ((eq sym :style-resize)
+ (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
+ ((eq sym :style-sysmenu)
+ (setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
+ ((eq sym :style-title)
+ (setf std-flags (logior std-flags gfs::+ws-caption+)))
+ ((eq sym :style-top)
+ (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+)))
+ ((eq sym :style-vscroll)
+ (setf std-flags (logior std-flags gfs::+ws-vscroll+)))
+|#
+
+ ;; pre-packaged combinations of window styles
+ ;;
+ ((eq sym :style-borderless)
+ (setf std-flags (logior gfs::+ws-clipchildren+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-border+
+ gfs::+ws-popup+))
+ (setf ex-flags gfs::+ws-ex-topmost+))
+ ((eq sym :style-palette)
+ (setf std-flags (logior gfs::+ws-clipchildren+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-popupwindow+
+ gfs::+ws-caption+))
+ (setf ex-flags (logior gfs::+ws-ex-toolwindow+
+ gfs::+ws-ex-windowedge+)))
+ ((eq sym :style-miniframe)
+ (setf std-flags (logior gfs::+ws-clipchildren+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-popup+
+ gfs::+ws-thickframe+
+ gfs::+ws-sysmenu+
+ gfs::+ws-caption+))
+ (setf ex-flags (logior gfs::+ws-ex-appwindow+
+ gfs::+ws-ex-toolwindow+)))
+ ((eq sym :style-workspace)
+ (setf std-flags (logior gfs::+ws-overlappedwindow+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-clipchildren+))
+ (setf ex-flags 0))))
+ (flatten style))
+ (values std-flags ex-flags)))
+
+(defmethod gfi:dispose ((win top-level))
+ (let ((m (menu-bar win)))
+ (unless (null m)
+ (visit-menu-tree m #'menu-cleanup-callback)
+ (remove-widget (thread-context) (gfi:handle m))))
+ (call-next-method))
+
+(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys)
+ (unless (null owner)
+ (if (gfi:disposed-p owner)
+ (error 'gfi:disposed-error)))
+ (if (null title)
+ (setf title +default-window-title+))
+ (if (not (listp style))
+ (setf style (list style)))
+ (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title))
+
+(defmethod menu-bar :before ((win top-level))
+ (if (gfi:disposed-p win)
+ (error 'gfi:disposed-error)))
+
+(defmethod menu-bar ((win top-level))
+ (let ((hmenu (gfs::get-menu (gfi:handle win))))
+ (if (gfi:null-handle-p hmenu)
+ (return-from menu-bar nil))
+ (let ((m (get-widget (thread-context) hmenu)))
+ (if (null m)
+ (error 'gfs:toolkit-error :detail "no object for menu handle"))
+ m)))
+
+(defmethod (setf menu-bar) :before ((m menu) (win top-level))
+ (declare (ignore m))
+ (if (gfi:disposed-p win)
+ (error 'gfi:disposed-error)))
+
+(defmethod (setf menu-bar) ((m menu) (win top-level))
+ (let* ((hwnd (gfi:handle win))
+ (hmenu (gfs::get-menu hwnd))
+ (old-menu (get-widget (thread-context) hmenu)))
+ (unless (gfi:null-handle-p hmenu)
+ (gfs::destroy-menu hmenu))
+ (unless (null old-menu)
+ (gfi:dispose old-menu))
+ (gfs::set-menu hwnd (gfi:handle m))
+ (gfs::draw-menu-bar hwnd)))
+
+(defmethod text :before ((win top-level))
+ (if (gfi:disposed-p win)
+ (error 'gfi:disposed-error)))
+
+(defmethod text ((win top-level))
+ (get-widget-text win))
+
+(defmethod (setf text) :before (str (win top-level))
+ (declare (ignore str))
+ (if (gfi:disposed-p win)
+ (error 'gfi:disposed-error)))
+
+(defmethod (setf text) (str (win top-level))
+ (set-widget-text win str))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 17 00:42:11 2006
@@ -60,7 +60,7 @@
(:documentation "The caret class provides an i-beam typically representing an insertion point."))
(defclass control (widget) ()
- (:documentation "The base class for widgets that process user input and/or display items."))
+ (:documentation "The base class for widgets having pre-defined native behavior."))
(defclass button (control) ()
(:documentation "This class represents selectable controls that issue notifications when clicked."))
@@ -76,7 +76,7 @@
:accessor items
;; FIXME: allow subclasses to set initial size?
:initform (make-array 7 :fill-pointer 0 :adjustable t)))
- (:documentation "The widget-with-items class is the base class for objects composed of fine-grained items."))
+ (:documentation "The widget-with-items class is the base class for objects composed of sub-items."))
(defclass menu (widget-with-items) ()
(:documentation "The menu class represents a container for menu items (and submenus)."))
@@ -89,4 +89,10 @@
:accessor layout-of
:initarg :layout
:initform nil))
- (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows)."))
+ (:documentation "Base class for user-defined widgets that serve as containers."))
+
+(defclass panel (window) ()
+ (:documentation "Base class for windows that are children of top-level windows (or other panels)."))
+
+(defclass top-level (window) ()
+ (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 17 00:42:11 2006
@@ -255,9 +255,6 @@
(defgeneric preferred-size (object width-hint height-hint)
(:documentation "Returns a size object representing the object's 'preferred' size."))
-(defgeneric realize (object parent &rest style)
- (:documentation "Realizes the object on the screen."))
-
(defgeneric redraw (object)
(:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn"))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 17 00:42:11 2006
@@ -179,6 +179,10 @@
(declare (ignore w))
nil)
+(defmethod size :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod size ((w widget))
(client-size w))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 17 00:42:11 2006
@@ -33,14 +33,27 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow")
-
-(defconstant +default-window-title+ "New Window")
-
;;;
;;; helper functions
;;;
+(defun init-window (win classname register-class-fn style 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)
+ (create-window classname
+ text
+ (if (null parent) (cffi:null-pointer) (gfi:handle parent))
+ std-style
+ ex-style))
+ (clear-widget-in-progress tc)
+ (let ((hwnd (gfi:handle win)))
+ (if (not hwnd) ; handle slot should have been set during create-window
+ (error 'gfs:win32-error :detail "create-window failed"))
+ (put-widget tc win))))
+
#+lispworks
(fli:define-foreign-callable
("child_window_visitor" :result-type :integer :calling-convention :stdcall)
@@ -85,7 +98,7 @@
(pop-child-visitor-func tc)))
nil)
-(defun register-window-class (class-name proc-ptr st)
+(defun register-window-class (class-name proc-ptr style bkgcolor)
(let ((retval 0))
(cffi:with-foreign-string (str-ptr class-name)
(cffi:with-foreign-object (wc-ptr 'gfs::wndclassex)
@@ -100,7 +113,7 @@
str-ptr wc-ptr))
(progn
(setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex))
- (setf gfs::style st)
+ (setf gfs::style style)
(setf gfs::wndproc proc-ptr)
(setf gfs::clsextra 0)
(setf gfs::wndextra 0)
@@ -111,7 +124,7 @@
gfs::+image-cursor+ 0 0
(logior gfs::+lr-defaultcolor+
gfs::+lr-shared+)))
- (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+)))
+ (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor)))
(setf gfs::menuname (cffi:null-pointer))
(setf gfs::classname str-ptr)
(setf gfs::smallicon (cffi:null-pointer))
@@ -130,16 +143,13 @@
(setf ,var (reverse ,var))
, at body)))
-(defun register-workspace-window-class ()
- (register-window-class +workspace-window-classname+
- (cffi:get-callback 'uit_widgets_wndproc)
- (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+)))
-
;;;
;;; methods
;;;
(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 (gfi:make-size :width (gfi:size-width desired-client-size)
@@ -150,72 +160,6 @@
(gfi:size-height client-sz)))
trim-sz))
-(defmethod compute-style-flags ((win window) &rest style)
- (declare (ignore win))
- (let ((std-flags 0)
- (ex-flags 0))
- (mapc #'(lambda (sym)
- (cond
- ;; styles that can be combined
- ;;
- ((eq sym :style-hscroll)
- (setf std-flags (logior std-flags gfs::+ws-hscroll+)))
-#|
- ((eq sym :style-max)
- (setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
- ((eq sym :style-min)
- (setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
- ((eq sym :style-resize)
- (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
- ((eq sym :style-sysmenu)
- (setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
- ((eq sym :style-title)
- (setf std-flags (logior std-flags gfs::+ws-caption+)))
- ((eq sym :style-top)
- (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+)))
-|#
- ((eq sym :style-vscroll)
- (setf std-flags (logior std-flags gfs::+ws-vscroll+)))
-
- ;; pre-packaged combinations of window styles
- ;;
- ((eq sym :style-borderless)
- (setf std-flags (logior gfs::+ws-clipchildren+
- gfs::+ws-clipsiblings+
- gfs::+ws-border+
- gfs::+ws-popup+))
- (setf ex-flags gfs::+ws-ex-topmost+))
- ((eq sym :style-palette)
- (setf std-flags (logior gfs::+ws-clipchildren+
- gfs::+ws-clipsiblings+
- gfs::+ws-popupwindow+
- gfs::+ws-caption+))
- (setf ex-flags (logior gfs::+ws-ex-toolwindow+
- gfs::+ws-ex-windowedge+)))
- ((eq sym :style-miniframe)
- (setf std-flags (logior gfs::+ws-clipchildren+
- gfs::+ws-clipsiblings+
- gfs::+ws-popup+
- gfs::+ws-thickframe+
- gfs::+ws-sysmenu+
- gfs::+ws-caption+))
- (setf ex-flags (logior gfs::+ws-ex-appwindow+
- gfs::+ws-ex-toolwindow+)))
- ((eq sym :style-workspace)
- (setf std-flags (logior gfs::+ws-overlappedwindow+
- gfs::+ws-clipsiblings+
- gfs::+ws-clipchildren+))
- (setf ex-flags 0))))
- (flatten style))
- (values std-flags ex-flags)))
-
-(defmethod gfi:dispose ((win window))
- (let ((m (menu-bar win)))
- (unless (null m)
- (visit-menu-tree m #'menu-cleanup-callback)
- (remove-widget (thread-context) (gfi:handle m))))
- (call-next-method))
-
(defmethod enable-layout :before ((win window) flag)
(declare (ignore flag))
(if (gfi:disposed-p win)
@@ -232,37 +176,17 @@
(let ((sz (client-size win)))
(perform-layout win (gfi:size-width sz) (gfi:size-height sz))))
-(defmethod location ((w window))
- (if (gfi:disposed-p w)
+(defmethod location ((win window))
+ (if (gfi:disposed-p win)
(error 'gfi:disposed-error))
(let ((pnt (gfi:make-point)))
- (outer-location w pnt)
+ (outer-location win pnt)
pnt))
(defmethod layout ((win window))
(let ((sz (client-size win)))
(perform-layout win (gfi:size-width sz) (gfi:size-height sz))))
-(defmethod menu-bar ((win window))
- (let ((hmenu (gfs::get-menu (gfi:handle win))))
- (if (gfi:null-handle-p hmenu)
- (return-from menu-bar nil))
- (let ((m (get-widget (thread-context) hmenu)))
- (if (null m)
- (error 'gfs:toolkit-error :detail "no object for menu handle"))
- m)))
-
-(defmethod (setf menu-bar) ((m menu) (win window))
- (let* ((hwnd (gfi:handle win))
- (hmenu (gfs::get-menu hwnd))
- (old-menu (get-widget (thread-context) hmenu)))
- (unless (gfi:null-handle-p hmenu)
- (gfs::destroy-menu hmenu))
- (unless (null old-menu)
- (gfi:dispose old-menu))
- (gfs::set-menu hwnd (gfi:handle m))
- (gfs::draw-menu-bar hwnd)))
-
(defmethod pack ((win window))
(perform-layout win -1 -1)
(call-next-method))
@@ -274,42 +198,12 @@
(compute-outer-size win new-client-sz))
(size win))))
-(defmethod realize ((win window) parent &rest style)
- (if (not (gfi:disposed-p win))
- (error 'gfs:toolkit-error :detail "object already realized"))
- (unless (null parent)
- (if (gfi:disposed-p parent)
- (error 'gfi:disposed-error)))
- (let ((tc (thread-context)))
- (setf (widget-in-progress tc) win)
- (register-workspace-window-class)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags win style)
- (create-window +workspace-window-classname+
- +default-window-title+
- (if (null parent) (cffi:null-pointer) (gfi:handle parent))
- std-style
- ex-style))
- (clear-widget-in-progress tc)
- (let ((hwnd (gfi:handle win)))
- (if (not hwnd) ; handle slot should have been set during create-window
- (error 'gfs:win32-error :detail "create-window failed"))
- (put-widget tc win))))
-
(defmethod show ((win window) flag)
(declare (ignore flag))
(call-next-method)
(gfs::update-window (gfi:handle win)))
(defmethod size ((win window))
- (if (gfi:disposed-p win)
- (error 'gfi:disposed-error))
(let ((sz (gfi:make-size)))
(outer-size win sz)
sz))
-
-(defmethod text ((win window))
- (get-widget-text win))
-
-(defmethod (setf text) (str (win window))
- (set-widget-text win str))
More information about the Graphic-forms-cvs
mailing list