Author: junrue Date: Wed Jul 5 00:18:46 2006 New Revision: 176

Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: promoted mapchildren to a widget generic function and cleaned up its semantics, and got rid of with-children at the same time

Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Jul 5 00:18:46 2006 @@ -1,5 +1,5 @@

-Graphic-Forms README for version 0.4.0 +Graphic-Forms README for version 0.5.0 Copyright (c) 2006, Jack D. Unrue

Graphic-Forms is a user interface library implemented in Common Lisp focusing

Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Jul 5 00:18:46 2006 @@ -1107,6 +1107,13 @@ system. @xref{parent}. @end deffn

+@deffn GenericFunction mapchildren self func => result-list +Calls @code{func}, which is a function of two arguments, for each +child of @code{self} and places @code{func}'s return value in +@code{result-list}. @code{func}'s two arguments are @code{self} and +the current child. +@end deffn + @anchor{maximum-size} @deffn GenericFunction maximum-size self => size Returns a @ref{size} object describing the largest dimensions to which

Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Jul 5 00:18:46 2006 @@ -126,7 +126,7 @@

@titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.4 +@c @subtitle Version 0.5 @c @author Jack D. Unrue

@page @@ -136,7 +136,7 @@

@ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.4) +@top Graphic-Forms Programming Reference (version 0.5) @insertcopying @end ifnottex

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jul 5 00:18:46 2006 @@ -423,6 +423,7 @@ #:location #:lock #:locked-p + #:mapchildren #:maximize #:maximized-p #:maximum-size @@ -493,7 +494,6 @@ #:vertical-scrollbar #:visible-item-count #:visible-p - #:with-children #:with-file-dialog #:with-font-dialog

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jul 5 00:18:46 2006 @@ -172,24 +172,29 @@ (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 (gfw::append-item menu (gfw:text k) nil nil))) - (unless (null (sub-disp-class-of d)) - (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) - (unless (null (check-test-fn d)) - (gfw:check it (funcall (check-test-fn d) k))))))) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (let ((it (gfw::append-item menu (gfw:text child) nil nil))) + (unless (null (sub-disp-class-of d)) + (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) + (unless (null (check-test-fn d)) + (gfw:check it (funcall (check-test-fn d) child))))))) + +(defun find-victim (text) + (let ((victim nil)) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (if (string= (gfw:text child) text) + (setf victim child)))) + victim))

(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)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) (gfw:layout *layout-tester-win*)))) @@ -198,12 +203,7 @@

(defmethod gfw:event-select ((d visibility-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)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*))))

Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jul 5 00:18:46 2006 @@ -83,10 +83,13 @@ (error 'gfs:disposed-error)))

(defmethod cancel-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idcancel+) + (setf kid child)))) + kid))

(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -118,10 +121,13 @@ (error 'gfs:disposed-error)))

(defmethod default-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idok+) + (setf kid child)))) + kid))

(defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))

Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Wed Jul 5 00:18:46 2006 @@ -171,11 +171,15 @@ ;;;

(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (let ((kids (mapchildren win (lambda (parent child) + (declare (ignore parent)) + child)))) (flow-container-size layout (visible-p win) kids width-hint height-hint)))

(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (let ((kids (mapchildren win (lambda (parent child) + (declare (ignore parent)) + child)))) (flow-container-layout layout (visible-p win) kids width-hint height-hint)))

(defmethod initialize-instance :after ((layout flow-layout) &key)

Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 00:18:46 2006 @@ -39,13 +39,13 @@

(defmethod compute-size ((self heap-layout) win width-hint height-hint) (let ((size (gfs:make-size))) - (with-children (win kids) - (loop for kid in kids - do (let ((kid-size (preferred-size kid width-hint height-hint))) - (setf (gfs:size-width size) (max (gfs:size-width size) - (gfs:size-width kid-size)) - (gfs:size-height size) (max (gfs:size-height size) - (gfs:size-height kid-size)))))) + (mapchildren win (lambda (parent kid) + (declare (ignore parent)) + (let ((kid-size (preferred-size kid width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size)))))) (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) size)) @@ -64,8 +64,9 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (with-children (win kids) - (loop for kid in kids collect (cons kid bounds))))) + (mapchildren win (lambda (parent kid) + (declare (ignore parent)) + (cons kid bounds)))))

(defmethod perform ((self heap-layout) win width-hint height-hint) (let ((kids nil)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Jul 5 00:18:46 2006 @@ -204,6 +204,9 @@ (defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified."))

+(defgeneric mapchildren (self func) + (:documentation "Executes func for each direct child of self.")) + (defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size)."))

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Jul 5 00:18:46 2006 @@ -61,52 +61,35 @@ (put-kbdnav-widget tc win)) (put-widget tc win))))

+(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro child-visitor-proper (hwnd lparam) + (let ((tc (gensym)) + (tmp-list (gensym)) + (child (gensym)) + (parent (gensym)) + (ancestor-hwnd (gensym))) + `(let* ((,tc (thread-context)) + (,child (get-widget ,tc ,hwnd)) + (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) + (unless (or (null ,parent) (null ,child)) + (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) + (,tmp-list (child-visitor-results ,tc))) + (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) + (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1)

#+clisp (defun child_window_visitor (hwnd lparam) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null child) (null parent)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1)

-(defun mapchildren (win func) - ;; - ;; supplied closure should expect two parameters: - ;; parent window object - ;; current child widget - ;; - (let ((tc (thread-context))) - (setf (child-visitor-func tc) func) - (unwind-protect -#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle win))) -#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle win))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle win)))) - (setf (child-visitor-func tc) nil)) - (let ((tmp (reverse (child-visitor-results tc)))) - (setf (child-visitor-results tc) nil) - tmp))) - (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) @@ -153,17 +136,6 @@ (defun release-mouse () (gfs::release-capture))

-(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro with-children ((win var) &body body) - (let ((hwnd (gensym))) - `(let ((,var (mapchildren ,win (lambda (parent child) - (let ((,hwnd (gfs::get-ancestor - (gfs:handle child) - gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child (child-visitor-results (thread-context))))))))) - ,@body)))) - ;;; ;;; methods ;;; @@ -242,6 +214,28 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))

+(defmethod mapchildren ((self window) func) + (let ((tc (thread-context))) + (setf (child-visitor-func tc) func) + (unwind-protect +#+lispworks + (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (fli:make-pointer :symbol-name "child_window_visitor") + (cffi:pointer-address (gfs:handle self))) +#+clisp + (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (setf ptr (ffi:set-foreign-pointer + (ffi:unsigned-foreign-address + (cffi:pointer-address (gfs:handle self))) + ptr)) + (gfs::enum-child-windows ptr + #'child_window_visitor + (cffi:pointer-address (gfs:handle self)))) + (setf (child-visitor-func tc) nil)) + (let ((tmp (reverse (child-visitor-results tc)))) + (setf (child-visitor-results tc) nil) + tmp))) + (defmethod (setf maximum-size) :after (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) (let ((size (constrain-new-size max-size (size self) #'min)))