[graphic-forms-cvs] r7 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets

Author: junrue Date: Sun Feb 12 19:25:36 2006 New Revision: 7

Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: now mapping widget screen coordinates to parent window coordinates; implemented enum windows callback with vendor-specific FFI because CFFI does not yet support stdcall as a language type

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Feb 12 19:25:36 2006 @@ -290,6 +290,7 @@ #:accelerator #:active #:alignment + #:ancestor-p #:append-item #:background-color #:background-pattern @@ -390,7 +391,6 @@ #:key-down-p #:key-toggled-p #:layout - #:layout-children #:layout-manager #:layout-p #:lines-visible-p @@ -458,6 +458,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-children

;; conditions ))

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 12 19:25:36 2006 @@ -33,8 +33,10 @@

(in-package #:graphic-forms.uitoolkit.tests)

-(defconstant +btn-text-1+ "Push Me") -(defconstant +btn-text-2+ "Again!") +(defconstant +btn-text-before+ "Push Me") +(defconstant +btn-text-after+ "Again!") + +(defvar *button-counter* 0)

(defparameter *layout-tester-win* nil)

@@ -50,18 +52,55 @@ (declare (ignore time)) (exit-layout-tester))

-(defclass layout-tester-btn-events (gfw:event-dispatcher) - ((button - :accessor button - :initarg :button +(defclass layout-tester-widget-events (gfw:event-dispatcher) + ((widget + :accessor widget + :initarg :widget :initform nil) (toggle-fn :accessor toggle-fn - :initform nil))) + :initform nil) + (id + :accessor id + :initarg :id + :initform 0))) + +(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)) + #'(lambda () + (if (null flag) + (progn + (setf flag t) + (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*))) + (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))))

-(defmethod gfw:event-select ((d layout-tester-btn-events) time item rect) +(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect)) - (let ((btn (button d))) + (let ((btn (widget d))) (setf (gfw:text btn) (funcall (toggle-fn d)))))

(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) @@ -71,13 +110,12 @@ (let* ((mb (gfw:menu-bar *layout-tester-win*)) (menu (gfw:sub-menu mb 1))) (gfw:clear-all menu) - (gfw::visit-child-widgets *layout-tester-win* - #'(lambda (child val) - (declare (ignore val)) - (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) - (setf (gfw:text it) (gfw:text child)))) - 0))) + (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))))

(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())

@@ -86,33 +124,21 @@ (exit-layout-tester))

(defun run-layout-tester-internal () + (setf *button-counter* 0) (let* ((menubar nil) (fed (make-instance 'layout-tester-exit-dispatcher)) - (be (make-instance 'layout-tester-btn-events)) - (cmd (make-instance 'layout-tester-child-menu-dispatcher)) - (btn (make-instance 'gfw:button :dispatcher be))) - (setf (button be) btn) - (setf (toggle-fn be) (let ((flag nil)) - #'(lambda () - (if (null flag) - (progn - (setf flag t) - +btn-text-1+) - (progn - (setf flag nil) - +btn-text-2+))))) + (cmd (make-instance 'layout-tester-child-menu-dispatcher))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events))) (gfw:realize *layout-tester-win* nil :style-workspace) - (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 200 :height 150)) + (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))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) - (gfw:realize btn *layout-tester-win* :push-button) - (setf (gfw:text btn) (funcall (toggle-fn be))) - (setf (gfw:location btn) (gfi:make-point)) - (setf (gfw:size btn) (gfw:preferred-size btn -1 -1)) + (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)))

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Feb 12 19:25:36 2006 @@ -172,6 +172,10 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000)

+(defconstant +ga-parent+ 1) +(defconstant +ga-root+ 2) +(defconstant +ga-rootowner+ 3) + (defconstant +gclp-menuname+ -8) (defconstant +gclp-hbrbackground+ -10) (defconstant +gclp-hcursor+ -12)

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 12 19:25:36 2006 @@ -39,6 +39,12 @@ (load-foreign-library "user32.dll")

(defcfun + ("GetAncestor" get-ancestor) + HANDLE + (hwnd HANDLE) + (flags UINT)) + +(defcfun ("BeginPaint" begin-paint) HANDLE (hwnd HANDLE) @@ -323,6 +329,12 @@ (flags UINT))

(defcfun + ("ScreenToClient" screen-to-client) + BOOL + (hwnd HANDLE) + (pnt :pointer)) + +(defcfun ("SendMessageA" send-message) LRESULT (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Feb 12 19:25:36 2006 @@ -42,6 +42,9 @@ (defgeneric alignment (object) (:documentation "Returns an integer describing the position of internal content within the object."))

+(defgeneric ancestor-p (ancestor descendant) + (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) + (defgeneric append-item (object new-item) (:documentation "Adds the new item to the end of the object's list."))

@@ -219,9 +222,6 @@ (defgeneric layout (object) (:documentation "Set the size and location of this object's children."))

-(defgeneric layout-children (object) - (:documentation "Return the children of this object which are organized via a layout manager.")) - (defgeneric layout-manager (object) (:documentation "Returns the layout manager associated with this object."))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Feb 12 19:25:36 2006 @@ -45,6 +45,15 @@ ;;; widget methods ;;;

+(defmethod ancestor-p ((ancestor widget) (descendant widget)) + (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) + (parent (get-widget parent-hwnd))) + (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) + (return-from ancestor-p t)) + (if (null parent) + (error 'gfs:toolkit-error :detail "no widget for parent handle")) + (ancestor-p ancestor parent))) + (defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -57,7 +66,7 @@ (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (gfi:make-size :width (- gfs::clientright gfs::clientleft) - :height (- gfs::clientbottom gfs::clienttop))))) + :height (- gfs::clientbottom gfs::clienttop)))))

(defmethod gfi:dispose ((w widget)) (unless (null (dispatcher w)) @@ -73,11 +82,21 @@ (error 'gfi:disposed-error)))

(defmethod location ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (let ((pnt (gfi:make-point))) - (outer-location w pnt) - pnt)) + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize + gfs::clientleft + gfs::clienttop) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (error 'gfs:win32-error :detail "get-window-info failed")) + (cffi:with-foreign-object (pnt-ptr 'gfs::point) + (cffi:with-foreign-slots ((gfs::x gfs::y) + pnt-ptr gfs::point) + (setf gfs::x gfs::clientleft) + (setf gfs::y gfs::clienttop) + (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)) (if (gfi:disposed-p w) @@ -96,11 +115,7 @@ (gfs::invalidate-rect hwnd nil 1))))

(defmethod size ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (let ((sz (gfi:make-size))) - (outer-size w sz) - sz)) + (client-size w))

(defmethod (setf size) ((sz gfi:size) (w widget)) (if (gfi:disposed-p w)

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 12 19:25:36 2006 @@ -48,29 +48,31 @@ ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let ((w (get-widget hwnd))) - (unless (or (null w) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) w lparam))) + (let ((child (get-widget hwnd)) + (parent (get-widget (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child) (null *child-visiting-functions*)) + (funcall (first *child-visiting-functions*) parent child))) 1)

#+clisp (defun child_window_visitor (hwnd lparam) - (let ((w (get-widget hwnd))) - (unless (or (null w) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) w lparam))) + (let ((child (get-widget hwnd)) + (parent (get-widget (cffi:make-pointer lparam)))) + (unless (or (null child) (null parent) (null *child-visiting-functions*)) + (funcall (first *child-visiting-functions*) parent child))) 1)

-(defun visit-child-widgets (win func val) +(defun visit-child-widgets (win func) ;; - ;; supplied closure should accept two parameters: + ;; supplied closure should expect two parameters: + ;; parent window object ;; current child widget - ;; long value passed to visit-child-windows ;; (push func *child-visiting-functions*) (unwind-protect #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") - 0) + (cffi:pointer-address (gfi:handle win))) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (setf ptr (ffi:set-foreign-pointer (ffi:unsigned-foreign-address @@ -78,7 +80,7 @@ ptr)) (gfs::enum-child-windows ptr #'child_window_visitor - 0)) + (cffi:pointer-address (gfi:handle win)))) (pop *child-visiting-functions*)))

(defun register-window-class (class-name proc-ptr st) @@ -117,6 +119,13 @@ 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)))) + ,@body)) + (defun register-workspace-window-class () (register-window-class +workspace-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) @@ -189,6 +198,13 @@ (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+))

+(defmethod location ((w window)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((pnt (gfi:make-point))) + (outer-location w pnt) + pnt)) + (defmethod menu-bar ((win window)) (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) @@ -233,3 +249,10 @@ (let ((hwnd (gfi:handle win))) (gfs::show-window hwnd gfs::+sw-shownormal+) (gfs::update-window hwnd))) + +(defmethod size ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((sz (gfi:make-size))) + (outer-size w sz) + sz))