[graphic-forms-cvs] r176 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Jul 5 04:18:48 UTC 2006
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
+ at 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
+ at code{result-list}. @code{func}'s two arguments are @code{self} and
+the current child.
+ at 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
- at c @subtitle Version 0.4
+ at c @subtitle Version 0.5
@c @author Jack D. Unrue
@page
@@ -136,7 +136,7 @@
@ifnottex
@node Top
- at top Graphic-Forms Programming Reference (version 0.4)
+ at 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)))))))))
- , at 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)))
More information about the Graphic-forms-cvs
mailing list