February 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r18 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 23 Feb '06

23 Feb '06

Author: junrue Date: Wed Feb 22 20:55:47 2006 New Revision: 18 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: fixed a mis-declaration of the msg parameter for wndproc defcallbacks Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Feb 22 20:55:47 2006 @@ -43,7 +43,7 @@ ;;; (cffi:defcallback uit_widgets_wndproc - gfs::LONG + gfs::UINT ((hwnd gfs::HANDLE) (msg gfs::UINT) (wparam gfs::WPARAM) @@ -51,7 +51,7 @@ (process-message hwnd msg wparam lparam)) (cffi:defcallback subclassing_wndproc - gfs::LONG + gfs::UINT ((hwnd gfs::HANDLE) (msg gfs::UINT) (wparam gfs::WPARAM) @@ -98,11 +98,12 @@ (defun process-mouse-message (fn hwnd lparam btn-symbol) (let* ((tc (thread-context)) - (w (get-widget tc hwnd))) + (w (get-widget tc hwnd)) + (pnt (mouse-event-pnt tc))) (when w - (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam)) - (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam)) - (funcall fn (dispatcher w) w (event-time tc) (mouse-event-pnt tc) btn-symbol))) + (setf (gfi:point-x pnt) (lo-word lparam)) + (setf (gfi:point-y pnt) (hi-word lparam)) + (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol))) 0) (defun get-class-wndproc (hwnd)

1 0

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

21 Feb '06

Author: junrue Date: Tue Feb 21 00:31:22 2006 New Revision: 17 Added: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented text-label widget, although mouse events currently cause a foreign type error Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Feb 21 00:31:22 2006 @@ -97,6 +97,7 @@ (:file "item") (:file "widget") (:file "control") + (:file "text-label") (:file "button") (:file "widget-with-items") (:file "menu") Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 21 00:31:22 2006 @@ -35,8 +35,9 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") +(defconstant +label-text+ "Test Label") -(defvar *button-counter* 0) +(defvar *widget-counter* 0) (defparameter *layout-tester-win* nil) @@ -68,7 +69,7 @@ :initform 0))) (defun add-layout-tester-widget (widget-class subtype) - (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) + (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) (w (make-instance widget-class :dispatcher be))) (cond ((eql subtype :push-button) @@ -80,10 +81,12 @@ (format nil "~d ~a" (id be) +btn-text-before+)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) - (incf *button-counter*))) + (format nil "~d ~a" (id be) +btn-text-after+))))))) + ((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) (funcall (toggle-fn be))) + (incf *widget-counter*))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) (declare (ignorable time rect)) @@ -167,11 +170,13 @@ (exit-layout-tester)) (defun run-layout-tester-internal () - (setf *button-counter* 0) + (setf *widget-counter* 0) (let ((menubar nil) (exit-disp (make-instance 'layout-tester-exit-dispatcher)) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (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 :item-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) @@ -182,7 +187,8 @@ (:menuitem "E&xit" :dispatcher ,exit-disp)) ((:menu "&Children") (:menuitem :submenu ((:menu "Add") - (:menuitem "Button" :dispatcher ,add-btn-disp))) + (:menuitem "Button" :dispatcher ,add-btn-disp) + (:menuitem "Label" :dispatcher ,add-text-label-disp))) (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp))) (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp)))) ((:menu "&Window") Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Feb 21 00:31:22 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.system) (defconstant +button-classname+ "button") +(defconstant +static-classname+ "static") (defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) @@ -467,6 +468,39 @@ (defconstant +sm-remotecontrol+ #x2001) (defconstant +sm-caretblinkingenabled+ #x2002) +(defconstant +ss-left+ #x00000000) +(defconstant +ss-center+ #x00000001) +(defconstant +ss-right+ #x00000002) +(defconstant +ss-icon+ #x00000003) +(defconstant +ss-blackrect+ #x00000004) +(defconstant +ss-grayrect+ #x00000005) +(defconstant +ss-whiterect+ #x00000006) +(defconstant +ss-blackframe+ #x00000007) +(defconstant +ss-grayframe+ #x00000008) +(defconstant +ss-whiteframe+ #x00000009) +(defconstant +ss-useritem+ #x0000000A) +(defconstant +ss-simple+ #x0000000B) +(defconstant +ss-leftnowordwrap+ #x0000000C) +(defconstant +ss-ownerdraw+ #x0000000D) +(defconstant +ss-bitmap+ #x0000000E) +(defconstant +ss-enhmetafile+ #x0000000F) +(defconstant +ss-etchedhorz+ #x00000010) +(defconstant +ss-etchedvert+ #x00000011) +(defconstant +ss-etchedframe+ #x00000012) +(defconstant +ss-typemask+ #x0000001F) +(defconstant +ss-realsizecontrol+ #x00000040) +(defconstant +ss-noprefix+ #x00000080) +(defconstant +ss-notify+ #x00000100) +(defconstant +ss-centerimage+ #x00000200) +(defconstant +ss-rightjust+ #x00000400) +(defconstant +ss-realsizeimage+ #x00000800) +(defconstant +ss-sunken+ #x00001000) +(defconstant +ss-editcontrol+ #x00002000) +(defconstant +ss-endellipsis+ #x00004000) +(defconstant +ss-pathellipsis+ #x00008000) +(defconstant +ss-wordellipsis+ #x0000C000) +(defconstant +ss-ellipsismask+ #x0000C000) + (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Feb 21 00:31:22 2006 @@ -41,40 +41,34 @@ (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) - (mapcar #'(lambda (sym) - (cond - ;; primary button styles - ;; - ((eq sym :check-box) - (setf std-flags gfs::+bs-checkbox+)) - ((eq sym :default-button) - (setf std-flags gfs::+bs-defpushbutton+)) - ((eq sym :push-button) - (setf std-flags gfs::+bs-pushbutton+)) - ((eq sym :radio-button) - (setf std-flags gfs::+bs-radiobutton+)) - ((eq sym :toggle-button) - (setf std-flags gfs::+bs-pushbox+)))) - (flatten style)) + (setf style (flatten style)) + ;; FIXME: check whether any of the primary button + ;; styles were specified, default to :push-button + ;; + (loop for sym in style + do (cond + ;; primary button styles + ;; + ((eq sym :check-box) + (setf std-flags gfs::+bs-checkbox+)) + ((eq sym :default-button) + (setf std-flags gfs::+bs-defpushbutton+)) + ((eq sym :push-button) + (setf std-flags gfs::+bs-pushbutton+)) + ((eq sym :radio-button) + (setf std-flags gfs::+bs-radiobutton+)) + ((eq sym :toggle-button) + (setf std-flags gfs::+bs-pushbox+)))) (values std-flags ex-flags))) (defmethod preferred-size ((btn button) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (let ((hwnd (gfi:handle btn)) - (sz (gfi:make-size)) - (count (length (text btn)))) - (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) - (cffi:with-foreign-slots ((gfs::tmheight - gfs::tmexternalleading - gfs::tmavgcharwidth) - tm-ptr gfs::textmetrics) - (gfs:with-retrieved-dc (hwnd dc) - (if (zerop (gfs::get-text-metrics dc tm-ptr)) - (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfi:size-width sz) (* gfs::tmavgcharwidth (+ count 2))) - (let ((tmp (+ gfs::tmexternalleading gfs::tmheight) )) - (setf (gfi:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1)))))) - sz)) + (text-widget-preferred-size btn + width-hint + height-hint + #'(lambda (char-width char-count) + (* char-width (+ char-count 2))) + #'(lambda (char-height) + (+ (floor (/ (* char-height 7) 5)) 1)))) (defmethod realize ((btn button) parent &rest style) (multiple-value-bind (std-style ex-style) Added: trunk/src/uitoolkit/widgets/text-label.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/text-label.lisp Tue Feb 21 00:31:22 2006 @@ -0,0 +1,100 @@ +;;;; +;;;; text-label.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) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((label text-label) &rest style) + (declare (ignore label)) + (let ((std-flags 0) + (ex-flags 0)) + (setf style (flatten style)) + (unless (or (find :beginning style) + (find :center style) + (find :end style)) + (setf std-flags gfs::+ss-leftnowordwrap+)) + (loop for sym in style + do (cond + ;; primary static styles + ;; + ((eq sym :beginning) + (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + ((eq sym :center) + (setf std-flags gfs::+ss-center+)) + ((eq sym :end) + (setf std-flags gfs::+ss-right+)) ; FIXME: i18n + + ;; styles that can be combined + ;; + ((eq sym :ellipsis) + (setf std-flags (logior std-flags gfs::+ss-endellipsis+))) + ((eq sym :raised) + (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-etchedframe+))) + ((eq sym :sunken) + (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-sunken+))) + ((eq sym :wrap) + (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-left+))))) + (values std-flags ex-flags))) + +(defmethod preferred-size ((label text-label) width-hint height-hint) + (text-widget-preferred-size label + width-hint + height-hint + #'(lambda (char-width char-count) + (+ (* char-width char-count) 2)) + #'(lambda (char-height) + (+ char-height 2)))) + +(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)) + +(defmethod (setf text) (str (label text-label)) + (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Feb 21 00:31:22 2006 @@ -65,6 +65,12 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) +(defclass image-label (control) () + (:documentation "This class represents non-selectable controls that display an image.")) + +(defclass text-label (control) () + (:documentation "This class represents non-selectable controls that display a string.")) + (defclass widget-with-items (widget) ((items :accessor items Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Feb 21 00:31:22 2006 @@ -123,3 +123,23 @@ (if (gfi:disposed-p w) (error 'gfi:disposed-error)) (gfs::set-window-text (gfi:handle w) str)) + +(defun text-widget-preferred-size (widget width-hint height-hint width-calc height-calc) + ;; FIXME: implement width-hint and height-hint constraints + ;; + (declare (ignorable width-hint height-hint)) + (let ((hwnd (gfi:handle widget)) + (sz (gfi:make-size)) + (count (length (text widget)))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight + gfs::tmexternalleading + gfs::tmavgcharwidth) + tm-ptr gfs::textmetrics) + (gfs:with-retrieved-dc (hwnd dc) + (if (zerop (gfs::get-text-metrics dc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfi:size-width sz) (funcall width-calc gfs::tmavgcharwidth count)) + (setf (gfi:size-height sz) (funcall height-calc (+ gfs::tmexternalleading + gfs::tmheight)))))) + sz))

1 0

[graphic-forms-cvs] r16 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 21 Feb '06

21 Feb '06

Author: junrue Date: Mon Feb 20 21:58:21 2006 New Revision: 16 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implement menu item check/uncheck; cleaned up some widget method names; added additional native handle error checking Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Feb 20 21:58:21 2006 @@ -292,6 +292,8 @@ #:background-pattern #:border-width #:caret + #:check + #:check-all #:checked-p #:clear-all #:clear-item @@ -376,7 +378,6 @@ #:hide-lines #:horizontal-scrollbar #:image - #:item-append #:item-at #:item-count #:item-height @@ -422,8 +423,9 @@ #:retrieve-span #:run-default-message-loop #:scroll + #:select #:select-all - #:selected + #:selected-p #:selection-count #:selection-index #:selection-indices @@ -450,6 +452,8 @@ #:traverse-order #:trim-sizes #:unlock + #:uncheck + #:uncheck-all #:update #:vertical-scrollbar #:visible-item-count Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 20 21:58:21 2006 @@ -109,6 +109,10 @@ ((item-disp-class :accessor item-disp-class :initarg :item-disp-class + :initform nil) + (check-test-fn + :accessor check-test-fn + :initarg :check-test-fn :initform nil))) (defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) @@ -117,10 +121,14 @@ (gfw:with-children (*layout-tester-win* kids) (loop for k in kids do (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) + (gfw:append-item menu it) (unless (null (item-disp-class d)) (setf (gfw:dispatcher it) (make-instance (item-disp-class d)))) - (setf (gfw:text it) (gfw:text k)))))) + (setf (gfw:text it) (gfw:text k)) + (unless (null (check-test-fn d)) + (if (funcall (check-test-fn d) k) + (gfw::check it) + (gfw::uncheck it))))))) (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) @@ -136,9 +144,9 @@ (gfi:dispose victim) (gfw:layout *layout-tester-win*)))) -(defclass hide-child-dispatcher (gfw:event-dispatcher) ()) +(defclass visibility-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) (declare (ignorable time rect)) (let ((text (gfw:text item)) (victim nil)) @@ -147,23 +155,11 @@ do (if (string= (gfw:text k) text) (setf victim k)))) (unless (null victim) - (gfw:hide victim) + (if (gfw:visible-p victim) + (gfw:hide victim) + (gfw:show victim)) (gfw:layout *layout-tester-win*)))) -(defclass show-child-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d show-child-dispatcher) item time rect) - (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) - (unless (null victim) - (gfw:show victim) - (gfw:pack *layout-tester-win*)))) - (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) (defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) @@ -177,8 +173,8 @@ (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher)) - (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher)) - (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher))) + (vis-menu-disp (make-instance 'child-menu-dispatcher :item-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-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) @@ -187,18 +183,13 @@ ((:menu "&Children") (:menuitem :submenu ((:menu "Add") (:menuitem "Button" :dispatcher ,add-btn-disp))) - (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp) - (:menuitem :separator))) - (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp) - (:menuitem :separator))) - (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp) - (:menuitem :separator)))) + (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp))) + (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp)))) ((:menu "&Window") (:menuitem "Pack" :dispatcher ,pack-disp) (:menuitem :submenu ((:menu "Select Layout") (:menuitem "Flow"))) - (:menuitem :submenu ((:menu "Modify Layout") - (:menuitem :separator))))))) + (:menuitem :submenu ((:menu "Modify Layout"))))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Feb 20 21:58:21 2006 @@ -43,12 +43,14 @@ (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))) (subclass-wndproc hwnd) (put-widget (thread-context) ctl) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Feb 20 21:58:21 2006 @@ -95,7 +95,54 @@ (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr)) (error 'gfs:win32-error :detail "set-menu-item-info failed"))))) -(defun insert-menuitem (howner mid label hbmp) +(defun check-menuitem (hmenu mid checked) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state (if checked gfs::+mfs-checked+ gfs::+mfs-unchecked+)) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer))) + (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "set-menu-item-info failed")))) + +(defun is-menuitem-checked (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 + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer)) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "set-menu-item-info failed")) + (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) + +(defun insert-menuitem (hmenu mid label hbmp) (cffi:with-foreign-string (str-ptr label) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type @@ -116,7 +163,7 @@ (setf gfs::tdata str-ptr) (setf gfs::cch (length label)) (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed"))))) (defun insert-submenu (hparent mid label hbmp hchildmenu) @@ -145,7 +192,7 @@ (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed"))))) -(defun insert-separator (howner) +(defun insert-separator (hmenu) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type gfs::state gfs::id gfs::hsubmenu @@ -165,7 +212,7 @@ (setf gfs::tdata (cffi:null-pointer)) (setf gfs::cch 0) (setf gfs::hbmpitem (cffi:null-pointer))) - (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed")))) (defun sub-menu (m index) @@ -188,6 +235,19 @@ ;;; menu methods ;;; +(defmethod append-item ((m menu) (it menu-item)) + (let* ((tc (thread-context)) + (id (next-menuitem-id tc)) + (hmenu (gfi:handle m))) + (if (gfi:null-handle-p hmenu) + (error 'gfi:disposed-error)) + (increment-menuitem-id tc) + (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) + (setf (item-id it) id) + (setf (slot-value it 'gfi:handle) hmenu) + (put-menuitem tc it) + (call-next-method))) + (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) (remove-widget tc (gfi:handle menu)) @@ -202,23 +262,22 @@ (error 'gfs:win32-error :detail "destroy-menu failed")))) (setf (slot-value m 'gfi:handle) nil)) -(defmethod item-append ((m menu) (it menu-item)) - (let* ((tc (thread-context)) - (id (next-menuitem-id tc)) - (hmenu (gfi:handle m))) - (if (gfi:null-handle-p hmenu) - (error 'gfi:disposed-error)) - (increment-menuitem-id tc) - (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) - (setf (item-id it) id) - (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem tc it) - (call-next-method))) - ;;; -;;; item methods +;;; menu-item methods ;;; +(defmethod check ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (check-menuitem hmenu (item-id it) t))) + +(defmethod checked-p ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (is-menuitem-checked hmenu (item-id it)))) + (defmethod gfi:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) @@ -254,6 +313,12 @@ (error 'gfs:toolkit-error :detail "null owner menu handle")) (set-menuitem-text hmenu (item-id it) str))) +(defmethod uncheck ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (check-menuitem hmenu (item-id it) nil))) + ;;; ;;; menu language compiler ;;; Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Feb 20 21:58:21 2006 @@ -60,8 +60,14 @@ (defgeneric caret-position (object) (:documentation "Returns a point describing the line number and character position of the caret.")) +(defgeneric check (object) + (:documentation "Sets the object into the checked state.")) + +(defgeneric check-all (object) + (:documentation "Sets all items in this object to the checked state.")) + (defgeneric checked-p (object) - (:documentation "Returns T if the item is checked; nil otherwise.")) + (:documentation "Returns T if the object is in the checked state; nil otherwise.")) (defgeneric clear-item (object index) (:documentation "Clears the item at the zero-based index.")) @@ -117,8 +123,8 @@ (defgeneric deiconified-p (object) (:documentation "Returns T if the object is in its normal, not iconified state.")) -(defgeneric deselect (object index) - (:documentation "Deselects the item at the given zero-based index in the object.")) +(defgeneric deselect (object) + (:documentation "Sets the object into the unselected state.")) (defgeneric deselect-all (object) (:documentation "Deselects all items in the object.")) @@ -201,9 +207,6 @@ (defgeneric image (object) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-append (object other) - (:documentation "Adds the item to the object.")) - (defgeneric item-at (object index) (:documentation "Return the item at the given zero-based index from the object.")) @@ -213,10 +216,10 @@ (defgeneric item-height (object) (:documentation "Return the height of the area if one of the object's items were displayed.")) -(defgeneric item-index (object other) +(defgeneric item-index (object item) (:documentation "Return the zero-based index of the location of the other object in this object.")) -(defgeneric item-owner (object) +(defgeneric item-owner (item) (:documentation "Return the widget containing this item.")) (defgeneric layout (object) @@ -315,10 +318,13 @@ (defgeneric scroll (object 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.")) +(defgeneric select (object) + (:documentation "Set this object into the selected state.")) + (defgeneric select-all (object) (:documentation "Set all items of this object to the selected state.")) -(defgeneric selected (object) +(defgeneric selected-p (object) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) (defgeneric selection-count (object) @@ -384,6 +390,12 @@ (defgeneric unlock (object) (:documentation "Allows this object's contents to be modified.")) +(defgeneric uncheck (object) + (:documentation "Sets the object into the unchecked state.")) + +(defgeneric uncheck-all (object) + (:documentation "Sets all items in this object to the unchecked state.")) + (defgeneric update (object) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Feb 20 21:58:21 2006 @@ -33,6 +33,19 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defmethod append-item :before ((w widget-with-items) (it item)) + (declare (ignore it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod append-item ((w widget-with-items) (it item)) + (vector-push-extend it (items w))) + +(defmethod clear-item :before ((w widget-with-items) index) + (declare (ignore index)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod clear-item ((w widget-with-items) index) (let ((it (item-at w index))) (delete it (items w) :test #'items-equal-p) @@ -40,24 +53,45 @@ (error 'gfi:disposed-error)) (gfi:dispose it))) +(defmethod clear-span :before ((w widget-with-items) (sp gfi:span)) + (declare (ignore sp)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod clear-span ((w widget-with-items) (sp gfi:span)) (loop for index from (gfi:span-start sp) to (gfi:span-end sp) collect (clear-item w 0))) -(defmethod item-append ((w widget-with-items) (i item)) - (vector-push-extend i (items w))) +(defmethod item-at :before ((w widget-with-items) index) + (declare (ignore index)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) (defmethod item-at ((w widget-with-items) index) (elt (items w) index)) -(defmethod (setf item-at) (index (i item) (w widget-with-items)) +(defmethod (setf item-at) :before (index (it item) (w widget-with-items)) + (declare (ignorable index it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod (setf item-at) (index (it item) (w widget-with-items)) (error 'gfs:toolkit-error :detail "not yet implemented")) +(defmethod item-count :before ((w widget-with-items)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod item-count ((w widget-with-items)) (length (items w))) -(defmethod item-index ((w widget-with-items) (i item)) - (let ((pos (position i (items w) :test #'items-equal-p))) +(defmethod item-index :before ((w widget-with-items) (it item)) + (declare (ignore it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod item-index ((w widget-with-items) (it item)) + (let ((pos (position it (items w) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 20 21:58:21 2006 @@ -41,6 +41,11 @@ ;;; widget methods ;;; +(defmethod ancestor-p :before ((ancestor widget) (descendant widget)) + (declare (ignore descendant)) + (if (gfi:disposed-p ancestor) + (error 'gfi:disposed-error))) + (defmethod ancestor-p ((ancestor widget) (descendant widget)) (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) (parent (get-widget (thread-context) parent-hwnd))) @@ -50,6 +55,18 @@ (error 'gfs:toolkit-error :detail "no widget for parent handle")) (ancestor-p ancestor parent))) +(defmethod checked-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod checked-p ((w widget)) + (declare (ignore w)) + nil) + +(defmethod client-size :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -80,6 +97,10 @@ (defmethod hide ((w widget)) (gfs::show-window (gfi:handle w) gfs::+sw-hide+)) +(defmethod location :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod location ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -97,9 +118,12 @@ (gfs::screen-to-client (gfi:handle w) pnt-ptr) (gfi:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) ((pnt gfi:point) (w widget)) +(defmethod (setf location) :before ((pnt gfi:point) (w widget)) + (declare (ignore pnt)) (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) + (error 'gfi:disposed-error))) + +(defmethod (setf location) ((pnt gfi:point) (w widget)) (if (zerop (gfs::set-window-pos (gfi:handle w) (cffi:null-pointer) (gfi:point-x pnt) @@ -108,17 +132,38 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) +(defmethod pack :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1))) +(defmethod redraw :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod redraw ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1)))) +(defmethod selected-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod selected-p ((w widget)) + (declare (ignore w)) + nil) + (defmethod size ((w widget)) (client-size w)) +(defmethod (setf size) :before ((sz gfi:size) (w widget)) + (declare (ignore sz)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod (setf size) ((sz gfi:size) (w widget)) (if (gfi:disposed-p w) (error 'gfi:disposed-error)) @@ -137,6 +182,10 @@ (defmethod show ((w widget)) (gfs::show-window (gfi:handle w) gfs::+sw-showna+)) +(defmethod update :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod update ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd)

1 0

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

20 Feb '06

Author: junrue Date: Mon Feb 20 00:58:33 2006 New Revision: 15 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/layouts.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented widget visibility interaction with flow layout Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 20 00:58:33 2006 @@ -52,6 +52,12 @@ (declare (ignore widget time)) (exit-layout-tester)) +(defclass pack-layout-dispatcher (gfw:event-dispatcher) ()) + +(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect) + (declare (ignorable item time rect)) + (gfw:pack *layout-tester-win*)) + (defclass layout-tester-widget-events (gfw:event-dispatcher) ((toggle-fn :accessor toggle-fn @@ -61,11 +67,11 @@ :initarg :id :initform 0))) -(defun add-layout-tester-widget (primary-type sub-type) +(defun add-layout-tester-widget (widget-class subtype) (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) - (w (make-instance primary-type :dispatcher be))) + (w (make-instance widget-class :dispatcher be))) (cond - ((eql sub-type :push-button) + ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) #'(lambda () (if (null flag) @@ -76,25 +82,88 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (incf *button-counter*))) - (gfw:realize w *layout-tester-win* sub-type) + (gfw:realize w *layout-tester-win* subtype) (setf (gfw:text w) (funcall (toggle-fn be))))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) (declare (ignorable time rect)) (setf (gfw:text btn) (funcall (toggle-fn d))) + (gfw:layout *layout-tester-win*)) + +(defclass add-child-dispatcher (gfw:event-dispatcher) + ((widget-class + :accessor widget-class + :initarg :widget-class + :initform 'gfw:button) + (subtype + :accessor subtype + :initarg :subtype + :initform :push-button))) + +(defmethod gfw:event-select ((d add-child-dispatcher) item time rect) + (declare (ignorable item time rect)) + (add-layout-tester-widget (widget-class d) (subtype d)) (gfw:pack *layout-tester-win*)) -(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) +(defclass child-menu-dispatcher (gfw:event-dispatcher) + ((item-disp-class + :accessor item-disp-class + :initarg :item-disp-class + :initform nil))) -(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) menu time) +(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) (declare (ignore time)) (gfw:clear-all menu) (gfw:with-children (*layout-tester-win* kids) (loop for k in kids do (let ((it (make-instance 'gfw:menu-item))) (gfw:item-append menu it) + (unless (null (item-disp-class d)) + (setf (gfw:dispatcher it) (make-instance (item-disp-class d)))) (setf (gfw:text it) (gfw:text k)))))) +(defclass remove-child-dispatcher (gfw:event-dispatcher) ()) + +(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect) + (declare (ignorable time rect)) + (let ((text (gfw:text item)) + (victim nil)) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (if (string= (gfw:text k) text) + (setf victim k)))) + (unless (null victim) + (gfi:dispose victim) + (gfw:layout *layout-tester-win*)))) + +(defclass hide-child-dispatcher (gfw:event-dispatcher) ()) + +(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect) + (declare (ignorable time rect)) + (let ((text (gfw:text item)) + (victim nil)) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (if (string= (gfw:text k) text) + (setf victim k)))) + (unless (null victim) + (gfw:hide victim) + (gfw:layout *layout-tester-win*)))) + +(defclass show-child-dispatcher (gfw:event-dispatcher) ()) + +(defmethod gfw:event-select ((d show-child-dispatcher) item time rect) + (declare (ignorable time rect)) + (let ((text (gfw:text item)) + (victim nil)) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (if (string= (gfw:text k) text) + (setf victim k)))) + (unless (null victim) + (gfw:show victim) + (gfw:pack *layout-tester-win*)))) + (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) (defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) @@ -103,21 +172,36 @@ (defun run-layout-tester-internal () (setf *button-counter* 0) - (let* ((menubar nil) - (fed (make-instance 'layout-tester-exit-dispatcher)) - (cmd (make-instance 'layout-tester-child-menu-dispatcher))) + (let ((menubar nil) + (exit-disp (make-instance 'layout-tester-exit-dispatcher)) + (pack-disp (make-instance 'pack-layout-dispatcher)) + (add-btn-disp (make-instance 'add-child-dispatcher)) + (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher)) + (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher)) + (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) - (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150)) (setf menubar (gfw:defmenusystem `(((:menu "&File") - (:menuitem "E&xit" :dispatcher ,fed)) - ((:menu "&Children" :dispatcher ,cmd) - (:menuitem :separator))))) + (:menuitem "E&xit" :dispatcher ,exit-disp)) + ((:menu "&Children") + (:menuitem :submenu ((:menu "Add") + (:menuitem "Button" :dispatcher ,add-btn-disp))) + (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp) + (:menuitem :separator))) + (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp) + (:menuitem :separator))) + (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp) + (:menuitem :separator)))) + ((:menu "&Window") + (:menuitem "Pack" :dispatcher ,pack-disp) + (:menuitem :submenu ((:menu "Select Layout") + (:menuitem "Flow"))) + (:menuitem :submenu ((:menu "Modify Layout") + (:menuitem :separator))))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) - (add-layout-tester-widget 'gfw:button :push-button) - (add-layout-tester-widget 'gfw:button :push-button) - (add-layout-tester-widget 'gfw:button :push-button) + (dotimes (i 3) + (add-layout-tester-widget 'gfw:button :push-button)) (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win*))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Mon Feb 20 00:58:33 2006 @@ -303,6 +303,11 @@ (erase BOOL)) (defcfun + ("IsWindowVisible" is-window-visible) + BOOL + (hwnd HANDLE)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE) Modified: trunk/src/uitoolkit/widgets/layouts.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layouts.lisp Mon Feb 20 00:58:33 2006 @@ -77,42 +77,44 @@ (with-children (win kids) (loop for k in kids do (let ((kid-size (preferred-size k width-hint height-hint))) - (if (not vert-orient) - (progn - (incf total (gfi:size-width kid-size)) - (if (< max (gfi:size-height kid-size)) - (setf max (gfi:size-height kid-size)))) - (progn - (incf total (gfi:size-height kid-size)) - (if (< max (gfi:size-width kid-size)) - (setf max (gfi:size-width kid-size)))))))) + (when (or (visible-p k) (not (visible-p win))) + (if (not vert-orient) + (progn + (incf total (gfi:size-width kid-size)) + (if (< max (gfi:size-height kid-size)) + (setf max (gfi:size-height kid-size)))) + (progn + (incf total (gfi:size-height kid-size)) + (if (< max (gfi:size-width kid-size)) + (setf max (gfi:size-width kid-size))))))))) (if vert-orient (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((layout-style (gfw:style layout)) - (entries nil) + (let ((entries nil) (last-coord 0) - (last-dim 0)) + (last-dim 0) + (vert-orient (find :vertical (gfw:style layout)))) (with-children (win kids) (loop for k in kids do (let ((kid-size (preferred-size k width-hint height-hint)) (pnt (gfi:make-point))) - (if (not (find :vertical layout-style)) - (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height kid-size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width kid-size))) - (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width kid-size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height kid-size)))) - (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries)))) + (when (or (visible-p k) (not (visible-p win))) + (if (not vert-orient) + (progn + (setf (gfi:point-x pnt) (+ last-coord last-dim)) + (if (>= height-hint 0) + (setf (gfi:size-height kid-size) height-hint)) + (setf last-coord (gfi:point-x pnt)) + (setf last-dim (gfi:size-width kid-size))) + (progn + (setf (gfi:point-y pnt) (+ last-coord last-dim)) + (if (>= width-hint 0) + (setf (gfi:size-width kid-size) width-hint)) + (setf last-coord (gfi:point-y pnt)) + (setf last-dim (gfi:size-height kid-size)))) + (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))) (reverse entries))) (defmethod initialize-instance :after ((layout flow-layout) &key style) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 20 00:58:33 2006 @@ -77,6 +77,9 @@ (if (gfi:disposed-p w) (error 'gfi:disposed-error))) +(defmethod hide ((w widget)) + (gfs::show-window (gfi:handle w) gfs::+sw-hide+)) + (defmethod location ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -131,7 +134,17 @@ (if (gfi:disposed-p w) (error 'gfi:disposed-error))) +(defmethod show ((w widget)) + (gfs::show-window (gfi:handle w) gfs::+sw-showna+)) + (defmethod update ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) (gfs::update-window hwnd)))) + +(defmethod visible-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod visible-p ((w widget)) + (not (zerop (gfs::is-window-visible (gfi:handle w)))))

1 0

[graphic-forms-cvs] r14 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 20 Feb '06

20 Feb '06

Author: junrue Date: Sun Feb 19 21:46:03 2006 New Revision: 14 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/layouts.lisp Log: implemented flow layout compute-size; window pack now works Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 19 21:46:03 2006 @@ -82,7 +82,7 @@ (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) (declare (ignorable time rect)) (setf (gfw:text btn) (funcall (toggle-fn d))) - (gfw:layout *layout-tester-win*)) + (gfw:pack *layout-tester-win*)) (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) @@ -118,6 +118,7 @@ (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) + (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win*))) (defun run-layout-tester () Modified: trunk/src/uitoolkit/widgets/layouts.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layouts.lisp Sun Feb 19 21:46:03 2006 @@ -71,7 +71,24 @@ ;;; (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (error "not yet implemented")) + (let ((max -1) + (total 0) + (vert-orient (find :vertical (gfw:style layout)))) + (with-children (win kids) + (loop for k in kids + do (let ((kid-size (preferred-size k width-hint height-hint))) + (if (not vert-orient) + (progn + (incf total (gfi:size-width kid-size)) + (if (< max (gfi:size-height kid-size)) + (setf max (gfi:size-height kid-size)))) + (progn + (incf total (gfi:size-height kid-size)) + (if (< max (gfi:size-width kid-size)) + (setf max (gfi:size-width kid-size)))))))) + (if vert-orient + (gfi:make-size :width max :height total) + (gfi:make-size :width total :height max)))) (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (let ((layout-style (gfw:style layout))

1 0

[graphic-forms-cvs] r13 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 20 Feb '06

20 Feb '06

Author: junrue Date: Sun Feb 19 21:23:23 2006 New Revision: 13 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed regression in with-children under LispWorks Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 19 21:23:23 2006 @@ -53,11 +53,7 @@ (exit-layout-tester)) (defclass layout-tester-widget-events (gfw:event-dispatcher) - ((widget - :accessor widget - :initarg :widget - :initform nil) - (toggle-fn + ((toggle-fn :accessor toggle-fn :initform nil) (id @@ -68,7 +64,6 @@ (defun add-layout-tester-widget (primary-type sub-type) (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) (w (make-instance primary-type :dispatcher be))) - (setf (widget be) w) (cond ((eql sub-type :push-button) (setf (toggle-fn be) (let ((flag nil)) @@ -81,20 +76,13 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (incf *button-counter*))) -#| - (gfw:with-children (*layout-tester-win* child-list) - (let ((child (first (reverse (rest child-list))))) - (unless (null child) - (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child)) - (gfi:size-width (gfw:size child))))))) -|# (gfw:realize w *layout-tester-win* sub-type) (setf (gfw:text w) (funcall (toggle-fn be))))) -(defmethod gfw:event-select ((d layout-tester-widget-events) item time rect) - (declare (ignorable item time rect)) - (let ((btn (widget d))) - (setf (gfw:text btn) (funcall (toggle-fn d))))) +(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) + (declare (ignorable time rect)) + (setf (gfw:text btn) (funcall (toggle-fn d))) + (gfw:layout *layout-tester-win*)) (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) @@ -130,7 +118,6 @@ (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) - (gfw:layout *layout-tester-win*) (gfw:show *layout-tester-win*))) (defun run-layout-tester () Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Feb 19 21:23:23 2006 @@ -113,9 +113,9 @@ (defun subclass-wndproc (hwnd) (if (zerop (gfs::set-window-long hwnd - gfs::+gwlp-wndproc+ - (cffi:pointer-address - (cffi:get-callback 'subclassing_wndproc)))) + gfs::+gwlp-wndproc+ + (cffi:pointer-address + (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) ;;; Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 19 21:23:23 2006 @@ -121,13 +121,14 @@ retval (error 'gfs::win32-error :detail "register-class failed"))))))) -(defmacro with-children ((win var) &body body) - `(let ((,var nil)) - (visit-child-widgets ,win #'(lambda (parent child) - (if (gfw:ancestor-p parent child) - (push child ,var)))) - (nreverse ,var) - ,@body)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-children ((win var) &body body) + `(let ((,var nil)) + (visit-child-widgets ,win #'(lambda (parent child) + (when (gfw:ancestor-p parent child) + (push child ,var)))) + (setf ,var (reverse ,var)) + ,@body))) (defun register-workspace-window-class () (register-window-class +workspace-window-classname+

1 0

[graphic-forms-cvs] r12 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 19 Feb '06

19 Feb '06

Author: junrue Date: Sun Feb 19 17:57:22 2006 New Revision: 12 Modified: trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: revised event generic methods to also pass receiving widget Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Feb 19 17:57:22 2006 @@ -46,16 +46,16 @@ (defclass event-tester-window-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-paint ((d event-tester-window-events) time gc rect) +(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) (declare (ignorable time rect)) (setf (gfg:background-color gc) gfg:+color-white+) (setf (gfg:foreground-color gc) gfg:+color-blue+) - (let* ((sz (gfw:client-size *event-tester-window*)) + (let* ((sz (gfw:client-size window)) (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) -(defmethod gfw:event-close ((d event-tester-window-events) time) - (declare (ignore time)) +(defmethod gfw:event-close ((d event-tester-window-events) widget time) + (declare (ignore widget time)) (exit-event-tester)) (defun text-for-modifiers () @@ -120,68 +120,68 @@ time (text-for-modifiers))) -(defmethod gfw:event-key-down ((d event-tester-window-events) time key-code char) +(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char) (setf *event-tester-text* (text-for-key "down" time key-code char)) - (gfw:redraw *event-tester-window*)) + (gfw:redraw window)) -(defmethod gfw:event-key-up ((d event-tester-window-events) time key-code char) +(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char) (setf *event-tester-text* (text-for-key "up" time key-code char)) - (gfw:redraw *event-tester-window*)) + (gfw:redraw window)) -(defmethod gfw:event-mouse-double ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button) (setf *event-tester-text* (text-for-mouse "double" time button pnt)) - (gfw:redraw *event-tester-window*)) + (gfw:redraw window)) -(defmethod gfw:event-mouse-down ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button) (setf *event-tester-text* (text-for-mouse "down" time button pnt)) (setf *mouse-down-flag* t) - (gfw:redraw *event-tester-window*)) + (gfw:redraw window)) -(defmethod gfw:event-mouse-move ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button) (when *mouse-down-flag* (setf *event-tester-text* (text-for-mouse "move" time button pnt)) - (gfw:redraw *event-tester-window*))) + (gfw:redraw window))) -(defmethod gfw:event-mouse-up ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button) (setf *event-tester-text* (text-for-mouse "up" time button pnt)) (setf *mouse-down-flag* nil) - (gfw:redraw *event-tester-window*)) + (gfw:redraw window)) -(defmethod gfw:event-move ((d event-tester-window-events) time pnt) +(defmethod gfw:event-move ((d event-tester-window-events) window time pnt) (setf *event-tester-text* (text-for-move time pnt)) - (gfw:redraw *event-tester-window*) + (gfw:redraw window) 0) -(defmethod gfw:event-resize ((d event-tester-window-events) time size type) +(defmethod gfw:event-resize ((d event-tester-window-events) window time size type) (setf *event-tester-text* (text-for-size type time size)) - (gfw:redraw *event-tester-window*) + (gfw:redraw window) 0) (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-exit-dispatcher) time item rect) - (declare (ignorable time item rect)) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect) + (declare (ignorable item time rect)) (exit-event-tester)) -(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) time item) +(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time) (declare (ignore rect)) (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) (gfw:redraw *event-tester-window*)) (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-echo-dispatcher) time item rect) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect) (declare (ignore rect)) (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) time item) +(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time) (declare (ignore rect)) (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) time) - (setf *event-tester-text* (text-for-item "" time "menu activated")) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time) + (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated")) (gfw:redraw *event-tester-window*)) (defun run-event-tester-internal () Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Feb 19 17:57:22 2006 @@ -43,21 +43,20 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) time) - (declare (ignore time)) - (format t "hellowin-events event-close~%") +(defmethod gfw:event-close ((d hellowin-events) widget time) + (declare (ignore widget time)) (exit-hello-world)) -(defmethod gfw:event-paint ((d hellowin-events) time (gc gfg:graphics-context) rect) - (declare (ignore time) (ignore rect)) +(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) + (declare (ignorable window time ignore rect)) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d hellowin-exit-dispatcher) time item rect) - (declare (ignorable time item rect)) +(defmethod gfw:event-select ((d hellowin-exit-dispatcher) item time rect) + (declare (ignorable item time rect)) (exit-hello-world)) (defun run-hello-world-internal () Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 19 17:57:22 2006 @@ -48,8 +48,8 @@ (defclass layout-tester-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d layout-tester-events) time) - (declare (ignore time)) +(defmethod gfw:event-close ((d layout-tester-events) widget time) + (declare (ignore widget time)) (exit-layout-tester)) (defclass layout-tester-widget-events (gfw:event-dispatcher) @@ -91,28 +91,26 @@ (gfw:realize w *layout-tester-win* sub-type) (setf (gfw:text w) (funcall (toggle-fn be))))) -(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d layout-tester-widget-events) item time rect) + (declare (ignorable item time rect)) (let ((btn (widget d))) (setf (gfw:text btn) (funcall (toggle-fn d))))) (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) time) +(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) menu time) (declare (ignore time)) - (let* ((mb (gfw:menu-bar *layout-tester-win*)) - (menu (gfw:sub-menu mb 1))) - (gfw:clear-all menu) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) - (setf (gfw:text it) (gfw:text k))))))) + (gfw:clear-all menu) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (let ((it (make-instance 'gfw:menu-item))) + (gfw:item-append menu it) + (setf (gfw:text it) (gfw:text k)))))) (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) time item rect) - (declare (ignorable time item rect)) +(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) + (declare (ignorable item time rect)) (exit-layout-tester)) (defun run-layout-tester-internal () Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Feb 19 17:57:22 2006 @@ -33,157 +33,157 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric event-activate (dispatcher time) +(defgeneric event-activate (dispatcher widget time) (:documentation "Implement this to respond to an object being activated.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-arm (dispatcher time item) +(defgeneric event-arm (dispatcher item time) (:documentation "Implement this to respond to an object about to be selected.") - (:method (dispatcher time item) - (declare (ignorable dispatcher time item)))) + (:method (dispatcher item time) + (declare (ignorable dispatcher item time)))) -(defgeneric event-close (dispatcher time) +(defgeneric event-close (dispatcher widget time) (:documentation "Implement this to respond to an object being closed.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-collapse (dispatcher time item rect) +(defgeneric event-collapse (dispatcher item time rect) (:documentation "Implement this to respond to an object (or item within) being collapsed.") - (:method (dispatcher time item rect) - (declare (ignorable dispatcher time item rect)))) + (:method (dispatcher item time rect) + (declare (ignorable dispatcher item time rect)))) -(defgeneric event-deactivate (dispatcher time) +(defgeneric event-deactivate (dispatcher widget time) (:documentation "Implement this to respond to an object being deactivated.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-deiconify (dispatcher time) +(defgeneric event-deiconify (dispatcher widget time) (:documentation "Implement this to respond to an object being deiconified.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-dispose (dispatcher time) +(defgeneric event-dispose (dispatcher widget time) (:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-expand (dispatcher time item rect) +(defgeneric event-expand (dispatcher item time rect) (:documentation "Implement this to respond to an object (or item within) being expanded.") - (:method (dispatcher time item rect) - (declare (ignorable dispatcher time item rect)))) + (:method (dispatcher item time rect) + (declare (ignorable dispatcher item time rect)))) -(defgeneric event-focus-gain (dispatcher time) +(defgeneric event-focus-gain (dispatcher widget time) (:documentation "Implement this to respond to an object gaining keyboard focus.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-focus-loss (dispatcher time) +(defgeneric event-focus-loss (dispatcher widget time) (:documentation "Implement this to respond to an object losing keyboard focus.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-hide (dispatcher time) +(defgeneric event-hide (dispatcher widget time) (:documentation "Implement this to respond to an object being hidden.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-iconify (dispatcher time) +(defgeneric event-iconify (dispatcher widget time) (:documentation "Implement this to respond to an object being iconified.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-key-down (dispatcher time keycode char) +(defgeneric event-key-down (dispatcher widget time keycode char) (:documentation "Implement this to respond to a key down event.") - (:method (dispatcher time keycode char) - (declare (ignorable dispatcher time keycode char)))) + (:method (dispatcher widget time keycode char) + (declare (ignorable dispatcher widget time keycode char)))) -(defgeneric event-key-traverse (dispatcher time keycode char type) +(defgeneric event-key-traverse (dispatcher widget time keycode char type) (:documentation "Implement this to respond to a key traversal event.") - (:method (dispatcher time keycode char type) - (declare (ignorable dispatcher time keycode char type)))) + (:method (dispatcher widget time keycode char type) + (declare (ignorable dispatcher widget time keycode char type)))) -(defgeneric event-key-up (dispatcher time keycode char) +(defgeneric event-key-up (dispatcher widget time keycode char) (:documentation "Implement this to respond to a key up event.") - (:method (dispatcher time keycode char) - (declare (ignorable dispatcher time keycode char)))) + (:method (dispatcher widget time keycode char) + (declare (ignorable dispatcher widget time keycode char)))) -(defgeneric event-modify (dispatcher time) +(defgeneric event-modify (dispatcher widget time) (:documentation "Implement this to respond to content (e.g., text) in an object being modified.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-mouse-double (dispatcher time point btn) +(defgeneric event-mouse-double (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse double-click.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-down (dispatcher time point btn) +(defgeneric event-mouse-down (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse down event.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-enter (dispatcher time point btn) +(defgeneric event-mouse-enter (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse passing into the bounds of an object.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-exit (dispatcher time point btn) +(defgeneric event-mouse-exit (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse leaving the bounds an object.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-hover (dispatcher time point btn) +(defgeneric event-mouse-hover (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-move (dispatcher time point btn) +(defgeneric event-mouse-move (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse move event.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-mouse-up (dispatcher time point btn) +(defgeneric event-mouse-up (dispatcher widget time point button) (:documentation "Implement this to respond to a mouse up event.") - (:method (dispatcher time point btn) - (declare (ignorable dispatcher time point btn)))) + (:method (dispatcher widget time point button) + (declare (ignorable dispatcher widget time point button)))) -(defgeneric event-move (dispatcher time point) +(defgeneric event-move (dispatcher widget time point) (:documentation "Implement this to respond to an object being moved within its parent's coordinate system.") - (:method (dispatcher time point) - (declare (ignorable dispatcher time point)))) + (:method (dispatcher widget time point) + (declare (ignorable dispatcher widget time point)))) -(defgeneric event-paint (dispatcher time gc rect) +(defgeneric event-paint (dispatcher widget time gc rect) (:documentation "Implement this to respond to paint requests.") - (:method (dispatcher time gc rect) - (declare (ignorable dispatcher time gc rect)))) + (:method (dispatcher widget time gc rect) + (declare (ignorable dispatcher widget time gc rect)))) -(defgeneric event-pre-modify (dispatcher time keycode char span new-content) +(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content) (:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.") - (:method (dispatcher time keycode char span new-content) - (declare (ignorable dispatcher time keycode char span new-content)))) + (:method (dispatcher widget time keycode char span new-content) + (declare (ignorable dispatcher widget time keycode char span new-content)))) -(defgeneric event-pre-move (dispatcher time) +(defgeneric event-pre-move (dispatcher widget time) (:documentation "Implement this to preempt moving; return T if processed or nil if not.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-pre-resize (dispatcher time) +(defgeneric event-pre-resize (dispatcher widget time) (:documentation "Implement this to preempt resizing; return T if processed or nil if not.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) -(defgeneric event-resize (dispatcher time size type) +(defgeneric event-resize (dispatcher widget time size type) (:documentation "Implement this to respond to an object being resized.") - (:method (dispatcher time size type) - (declare (ignorable dispatcher time size type)))) + (:method (dispatcher widget time size type) + (declare (ignorable dispatcher widget time size type)))) -(defgeneric event-select (dispatcher time item rect) +(defgeneric event-select (dispatcher item time rect) (:documentation "Implement this to respond to an object (or item within) being selected.") - (:method (dispatcher time item rect) - (declare (ignorable dispatcher time item rect)))) + (:method (dispatcher item time rect) + (declare (ignorable dispatcher item time rect)))) -(defgeneric event-show (dispatcher time) +(defgeneric event-show (dispatcher widget time) (:documentation "Implement this to respond to an object being shown.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher widget time) + (declare (ignorable dispatcher widget time)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Feb 19 17:57:22 2006 @@ -102,7 +102,7 @@ (when w (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam)) (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam)) - (funcall fn (dispatcher w) (event-time tc) (mouse-event-pnt tc) btn-symbol))) + (funcall fn (dispatcher w) w (event-time tc) (mouse-event-pnt tc) btn-symbol))) 0) (defun get-class-wndproc (hwnd) @@ -130,7 +130,7 @@ (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if w - (event-close (dispatcher w) (event-time tc)) + (event-close (dispatcher w) w (event-time tc)) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -146,8 +146,8 @@ (error 'gfs:toolkit-error :detail "no menu item for id")) (unless (null (dispatcher item)) (event-select (dispatcher item) - (event-time tc) item + (event-time tc) (make-instance 'gfi:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) @@ -157,8 +157,8 @@ (error 'gfs:toolkit-error :detail "no object for hwnd")) (unless (null (dispatcher w)) (event-select (dispatcher w) - (event-time tc) w + (event-time tc) (make-instance 'gfi:rectangle)))))) ; FIXME (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -170,7 +170,7 @@ (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d (event-time tc)))))) + (event-activate d menu (event-time tc)))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) @@ -180,7 +180,7 @@ (unless (null item) (let ((d (dispatcher item))) (unless (null d) - (event-arm d (event-time tc) item))))) + (event-arm d item (event-time tc)))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) @@ -199,7 +199,7 @@ (w (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) (when w - (event-key-down (dispatcher w) (event-time tc) (virtual-key tc) ch))) + (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) @@ -209,7 +209,7 @@ (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) - (event-key-down (dispatcher w) (event-time tc) wparam-lo (code-char ch)))) + (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) @@ -220,7 +220,7 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (when w - (event-key-up (dispatcher w) (event-time tc) wparam-lo (code-char ch))))) + (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))) (setf (virtual-key tc) 0)) 0) @@ -265,14 +265,14 @@ (w (get-widget tc hwnd))) (when w (outer-location w (move-event-pnt tc)) - (event-move (dispatcher w) (event-time tc) (move-event-pnt tc)))) + (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) (declare (ignorable wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) - (if (and w (event-pre-move (dispatcher w) (event-time tc))) + (if (and w (event-pre-move (dispatcher w) w (event-time tc))) 1 0))) @@ -295,7 +295,7 @@ (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (unwind-protect - (event-paint (dispatcher w) (event-time tc) gc rct) + (event-paint (dispatcher w) w (event-time tc) gc rct) (gfs::end-paint hwnd ps-ptr))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -323,14 +323,14 @@ (t nil)))) (when w (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) (event-time tc) (size-event-size tc) type))) + (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) (declare (ignorable wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) - (if (and w (event-pre-resize (dispatcher w) (event-time tc))) + (if (and w (event-pre-resize (dispatcher w) w (event-time tc))) 1 0))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Feb 19 17:57:22 2006 @@ -66,7 +66,7 @@ (defmethod gfi:dispose ((w widget)) (unless (null (dispatcher w)) - (event-dispose (dispatcher w) 0)) + (event-dispose (dispatcher w) w 0)) (let ((hwnd (gfi:handle w))) (if (not (gfi:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 19 17:57:22 2006 @@ -216,9 +216,9 @@ (setf (slot-value win 'layout-p) t) (layout win)) -(defmethod event-resize ((d dispatcher) time size type) - (declare (ignorable time size type)) - (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here! +(defmethod event-resize ((d event-dispatcher) (win window) time size type) + (declare (ignorable d time size type)) + (layout win)) (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+))

1 0

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

19 Feb '06

Author: junrue Date: Sun Feb 19 15:50:50 2006 New Revision: 11 Added: trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layouts.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: flow layout implementation Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Feb 19 15:50:50 2006 @@ -87,6 +87,7 @@ :components ((:file "widget-constants") (:file "widget-classes") + (:file "layout-classes") (:file "thread-context") (:file "message-generics") (:file "event-generics") @@ -100,4 +101,5 @@ (:file "widget-with-items") (:file "menu") (:file "event") - (:file "window"))))))))) + (:file "window") + (:file "layouts"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Feb 19 15:50:50 2006 @@ -205,7 +205,9 @@ #:control #:event-dispatcher #:event-source + #:flow-layout #:item + #:layout-manager #:menu #:menu-item #:widget @@ -305,7 +307,6 @@ #:column-order #:columns #:compute-outer-size - #:compute-size #:copy #:copy-area #:current-font @@ -408,7 +409,6 @@ #:parent #:paste #:peer - #:perform-layout #:preferred-size #:realize #:redraw Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 19 15:50:50 2006 @@ -67,8 +67,7 @@ (defun add-layout-tester-widget (primary-type sub-type) (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) - (w (make-instance primary-type :dispatcher be)) - (pnt (gfi:make-point))) + (w (make-instance primary-type :dispatcher be))) (setf (widget be) w) (cond ((eql sub-type :push-button) @@ -89,11 +88,8 @@ (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child)) (gfi:size-width (gfw:size child))))))) |# - (setf (gfi:point-x pnt) (* 77 (1- *button-counter*))) (gfw:realize w *layout-tester-win* sub-type) - (setf (gfw:text w) (funcall (toggle-fn be))) - (gfw:pack w) - (setf (gfw:location w) pnt))) + (setf (gfw:text w) (funcall (toggle-fn be))))) (defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect)) @@ -107,12 +103,11 @@ (let* ((mb (gfw:menu-bar *layout-tester-win*)) (menu (gfw:sub-menu mb 1))) (gfw:clear-all menu) - (gfw:with-children (*layout-tester-win* child-list) - (mapc #'(lambda (child) - (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) - (setf (gfw:text it) (gfw:text child)))) - child-list)))) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (let ((it (make-instance 'gfw:menu-item))) + (gfw:item-append menu it) + (setf (gfw:text it) (gfw:text k))))))) (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -125,7 +120,8 @@ (let* ((menubar nil) (fed (make-instance 'layout-tester-exit-dispatcher)) (cmd (make-instance 'layout-tester-child-menu-dispatcher))) - (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events))) + (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) + :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150)) (setf menubar (gfw:defmenusystem `(((:menu "&File") @@ -136,6 +132,7 @@ (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) + (gfw:layout *layout-tester-win*) (gfw:show *layout-tester-win*))) (defun run-layout-tester () Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 19 15:50:50 2006 @@ -39,10 +39,9 @@ (load-foreign-library "user32.dll") (defcfun - ("GetAncestor" get-ancestor) + ("BeginDeferWindowPos" begin-defer-window-pos) HANDLE - (hwnd HANDLE) - (flags UINT)) + (numwin INT)) (defcfun ("BeginPaint" begin-paint) @@ -89,6 +88,18 @@ (param LPVOID)) (defcfun + ("DeferWindowPos" defer-window-pos) + HANDLE + (posinfo HANDLE) + (hwnd HANDLE) + (hwndafter HANDLE) + (x INT) + (y INT) + (cx INT) + (cy INT) + (flags UINT)) + +(defcfun ("DefWindowProcA" def-window-proc) LRESULT (hwnd HANDLE) @@ -117,6 +128,11 @@ (hwnd HANDLE)) (defcfun + ("EndDeferWindowPos" end-defer-window-pos) + BOOL + (posinfo HANDLE)) + +(defcfun ("EndPaint" end-paint) BOOL (hwnd HANDLE) @@ -158,6 +174,12 @@ (:return-type ffi:int)) (defcfun + ("GetAncestor" get-ancestor) + HANDLE + (hwnd HANDLE) + (flags UINT)) + +(defcfun ("GetAsyncKeyState" get-async-key-state) SHORT (virtkey INT)) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Feb 19 15:50:50 2006 @@ -121,7 +121,7 @@ (defgeneric event-mouse-down (dispatcher time point btn) (:documentation "Implement this to respond to a mouse down event.") (:method (dispatcher time point btn) - (declare (ignorable dispatcher time ptn btn)))) + (declare (ignorable dispatcher time point btn)))) (defgeneric event-mouse-enter (dispatcher time point btn) (:documentation "Implement this to respond to a mouse passing into the bounds of an object.") Added: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Feb 19 15:50:50 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; layout-classes.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) + +(defclass layout-manager () + ((style + :accessor style + :initarg :style + :initform nil)) + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + +(defclass flow-layout (layout-manager) () + (:documentation "Window children are arranged in a row or column.")) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Feb 19 15:50:50 2006 @@ -33,8 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (mgr win width-hint height-hint) - (:documentation "Computes and returns the size of the window's client area based on this layout's strategy.")) +(defgeneric compute-size (layout win width-hint height-hint) + (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric perform-layout (mgr win) - (:documentation "Lays out the children of the window based on this layout's strategy.")) +(defgeneric compute-layout (layout win width-hint height-hint) + (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) Added: trunk/src/uitoolkit/widgets/layouts.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/layouts.lisp Sun Feb 19 15:50:50 2006 @@ -0,0 +1,106 @@ +;;;; +;;;; layouts.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 +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+)) + +(defun perform-layout (layout win) + "Calls compute-layout and then handles the actual moving and resizing of a window's children." + (let* ((win-size (client-size win)) + (kids (compute-layout layout win (gfi:size-width win-size) (gfi:size-height win-size))) + (hdwp (gfs::begin-defer-window-pos (length kids)))) + (loop for k in kids + do (let* ((rect (cdr k)) + (sz (gfi:size rect)) + (pnt (gfi:location rect))) + (if (gfi:null-handle-p hdwp) + (gfs::set-window-pos (gfi:handle (car k)) + (cffi:null-pointer) + (gfi:point-x pnt) + (gfi:point-y pnt) + (gfi:size-width sz) + (gfi:size-height sz) + +window-pos-flags+) + (setf hdwp (gfs::defer-window-pos hdwp + (gfi:handle (car k)) + (cffi:null-pointer) + (gfi:point-x pnt) + (gfi:point-y pnt) + (gfi:size-width sz) + (gfi:size-height sz) + +window-pos-flags+))))) + (unless (gfi:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp)))) + +;;; +;;; flow-layout methods +;;; + +(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) + (error "not yet implemented")) + +(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) + (let ((layout-style (gfw:style layout)) + (entries nil) + (last-coord 0) + (last-dim 0)) + (with-children (win kids) + (loop for k in kids + do (let ((kid-size (preferred-size k width-hint height-hint)) + (pnt (gfi:make-point))) + (if (not (find :vertical layout-style)) + (progn + (setf (gfi:point-x pnt) (+ last-coord last-dim)) + (if (>= height-hint 0) + (setf (gfi:size-height kid-size) height-hint)) + (setf last-coord (gfi:point-x pnt)) + (setf last-dim (gfi:size-width kid-size))) + (progn + (setf (gfi:point-y pnt) (+ last-coord last-dim)) + (if (>= width-hint 0) + (setf (gfi:size-width kid-size) width-hint)) + (setf last-coord (gfi:point-y pnt)) + (setf last-dim (gfi:size-height kid-size)))) + (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries)))) + (reverse entries))) + +(defmethod initialize-instance :after ((layout flow-layout) &key style) + (unless (listp style) + (setf style (list style))) + (if (and (null (find :horizontal style)) (null (find :vertical style))) + (setf (slot-value layout 'style) '(:horizontal)) + (setf (slot-value layout 'style) style))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Feb 19 15:50:50 2006 @@ -36,9 +36,6 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) -(defclass layout-manager () () - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) - (defclass event-source (gfi:native-object) ((dispatcher :accessor dispatcher @@ -80,7 +77,7 @@ (defclass window (widget) ((layout-p - :reader :layout-p + :reader layout-p :initform t) (layout-manager :accessor layout-manager Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 19 15:50:50 2006 @@ -126,6 +126,7 @@ (visit-child-widgets ,win #'(lambda (parent child) (if (gfw:ancestor-p parent child) (push child ,var)))) + (nreverse ,var) ,@body)) (defun register-workspace-window-class () @@ -215,6 +216,10 @@ (setf (slot-value win 'layout-p) t) (layout win)) +(defmethod event-resize ((d dispatcher) time size type) + (declare (ignorable time size type)) + (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here! + (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+))

1 0

[graphic-forms-cvs] r10 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 14 Feb '06

14 Feb '06

Author: junrue Date: Tue Feb 14 00:27:31 2006 New Revision: 10 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/layout-generics.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: initial implementation of window side of the layout management protocol Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Feb 14 00:27:31 2006 @@ -304,7 +304,8 @@ #:column-index #:column-order #:columns - #:compute-trim + #:compute-outer-size + #:compute-size #:copy #:copy-area #:current-font @@ -407,6 +408,7 @@ #:parent #:paste #:peer + #:perform-layout #:preferred-size #:realize #:redraw Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 14 00:27:31 2006 @@ -67,7 +67,8 @@ (defun add-layout-tester-widget (primary-type sub-type) (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) - (w (make-instance primary-type :dispatcher be))) + (w (make-instance primary-type :dispatcher be)) + (pnt (gfi:make-point))) (setf (widget be) w) (cond ((eql sub-type :push-button) @@ -81,22 +82,18 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (incf *button-counter*))) +#| + (gfw:with-children (*layout-tester-win* child-list) + (let ((child (first (reverse (rest child-list))))) + (unless (null child) + (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child)) + (gfi:size-width (gfw:size child))))))) +|# + (setf (gfi:point-x pnt) (* 77 (1- *button-counter*))) (gfw:realize w *layout-tester-win* sub-type) (setf (gfw:text w) (funcall (toggle-fn be))) - (let ((pnt (gfi:make-point))) - (gfw:with-children (*layout-tester-win* child-list) - (let ((last-child (car (last (cdr child-list))))) - (unless (null last-child) -(format t "****~%") -(format t "widget: ~a~%" (gfw:text last-child)) -(format t "location: ~a~%" (gfw:location last-child)) -(format t "size: ~a~%" (gfw:size last-child)) - (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child)) - (gfi:size-width (gfw:size last-child))))))) - (setf (gfw:location w) pnt) -(format t "++++~%") -(format t "location: ~a~%" (gfw:location w))) - (setf (gfw:size w) (gfw:preferred-size w -1 -1)))) + (gfw:pack w) + (setf (gfw:location w) pnt))) (defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect)) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Tue Feb 14 00:27:31 2006 @@ -32,3 +32,9 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) + +(defgeneric compute-size (mgr win width-hint height-hint) + (:documentation "Computes and returns the size of the window's client area based on this layout's strategy.")) + +(defgeneric perform-layout (mgr win) + (:documentation "Lays out the children of the window based on this layout's strategy.")) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Feb 14 00:27:31 2006 @@ -36,6 +36,9 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defclass layout-manager () () + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + (defclass event-source (gfi:native-object) ((dispatcher :accessor dispatcher @@ -75,5 +78,12 @@ (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) -(defclass window (widget) () - (:documentation "The window class is the base class for top-level window objects.")) +(defclass window (widget) + ((layout-p + :reader :layout-p + :initform t) + (layout-manager + :accessor layout-manager + :initarg :layout-manager + :initform nil)) + (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Feb 14 00:27:31 2006 @@ -96,8 +96,8 @@ (defgeneric compute-style-flags (object &rest style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) -(defgeneric compute-trim (object desired-rect) - (:documentation "Return a rectangle describing the area require to enclose the specified desired client area and this object's trim.")) +(defgeneric compute-outer-size (object desired-client-size) + (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim.")) (defgeneric copy (object) (:documentation "Copies the current selection to the clipboard.")) @@ -222,12 +222,6 @@ (defgeneric layout (object) (:documentation "Set the size and location of this object's children.")) -(defgeneric layout-manager (object) - (:documentation "Returns the layout manager associated with this object.")) - -(defgeneric layout-p (object) - (:documentation "Return T if this object is configured to allow layout management of children, or nil if layout has been disabled.")) - (defgeneric lines-visible-p (object) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Feb 14 00:27:31 2006 @@ -105,6 +105,9 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) +(defmethod pack ((w widget)) + (setf (size w) (preferred-size w -1 -1))) + (defmethod redraw ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Feb 14 00:27:31 2006 @@ -137,6 +137,17 @@ ;;; methods ;;; +(defmethod compute-outer-size ((win window) desired-client-size) + (let ((client-sz (client-size win)) + (outer-sz (size win)) + (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) + :height (gfi:size-height desired-client-size)))) + (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz) + (gfi:size-width client-sz))) + (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz) + (gfi:size-height client-sz))) + trim-sz)) + (defmethod compute-style-flags ((win window) &rest style) (declare (ignore win)) (let ((std-flags 0) @@ -190,6 +201,9 @@ (flatten style)) (values std-flags ex-flags))) +(defmethod disable-layout ((win window)) + (setf (slot-value win 'layout-p) nil)) + (defmethod gfi:dispose ((win window)) (let ((m (menu-bar win))) (unless (null m) @@ -197,6 +211,10 @@ (remove-widget (thread-context) (gfi:handle m)))) (call-next-method)) +(defmethod enable-layout ((win window)) + (setf (slot-value win 'layout-p) t) + (layout win)) + (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+)) @@ -207,6 +225,11 @@ (outer-location w pnt) pnt)) +(defmethod layout ((win window)) + (let ((mgr (layout-manager win))) + (when (and (layout-p win) mgr) + (perform-layout mgr win)))) + (defmethod menu-bar ((win window)) (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) @@ -227,6 +250,17 @@ (gfs::set-menu hwnd (gfi:handle m)) (gfs::draw-menu-bar hwnd))) +(defmethod pack ((win window)) + (layout win) + (call-next-method)) + +(defmethod preferred-size ((win window) width-hint height-hint) + (let ((mgr (layout-manager win))) + (if (and (layout-p win) mgr) + (let ((new-client-sz (compute-size mgr win width-hint height-hint))) + (compute-outer-size win new-client-sz)) + (size win)))) + (defmethod realize ((win window) parent &rest style) (if (not (null parent)) (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future

1 0

[graphic-forms-cvs] r9 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 14 Feb '06

14 Feb '06

Author: junrue Date: Mon Feb 13 21:15:34 2006 New Revision: 9 Modified: trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: invoke default message loop on behalf of application code Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Feb 13 21:15:34 2006 @@ -205,8 +205,7 @@ ((:menu "&Help" :dispatcher ,echo-md) (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) (setf (gfw:menu-bar *event-tester-window*) menubar) - (gfw:show *event-tester-window*) - (gfw:run-default-message-loop))) + (gfw:show *event-tester-window*))) (defun run-event-tester () (gfw:startup "Event Tester" #'run-event-tester-internal)) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Feb 13 21:15:34 2006 @@ -68,8 +68,7 @@ (setf menubar (gfw:defmenusystem `(((:menu "&File") (:menuitem "E&xit" :dispatcher ,md))))) (setf (gfw:menu-bar *hellowin*) menubar) - (gfw:show *hellowin*) - (gfw:run-default-message-loop))) + (gfw:show *hellowin*))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 13 21:15:34 2006 @@ -139,8 +139,7 @@ (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) - (gfw:show *layout-tester-win*) - (gfw:run-default-message-loop))) + (gfw:show *layout-tester-win*))) (defun run-layout-tester () (gfw:startup "Layout Tester" #'run-layout-tester-internal)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Feb 13 21:15:34 2006 @@ -36,12 +36,17 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (setf *the-thread-context* (make-instance 'thread-context)) - (funcall start-fn)) + (funcall start-fn) + (run-default-message-loop)) #+lispworks (defun startup (thread-name start-fn) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) - (mp:process-run-function thread-name nil start-fn)) + (mp:process-run-function thread-name + nil + #'(lambda () (progn + (funcall start-fn) + (run-default-message-loop))))) (defun shutdown (exit-code) (gfs::post-quit-message exit-code))

1 0