[graphic-forms-cvs] r7 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Feb 13 01:25:37 UTC 2006
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))))
+ , at 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))
More information about the Graphic-forms-cvs
mailing list