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