- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r248 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Sep '06

05 Sep '06

Author: junrue Date: Tue Sep 5 11:39:37 2006 New Revision: 248 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: converted update-native-style to a generic function, added other convenience functions for querying style flags Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 5 11:39:37 2006 @@ -546,9 +546,17 @@ @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's -data structures) with the list from the @var{items} slot -after that list has been sorted. Application code typically does not -need to call this function. +data structures) with data derived from the @var{items} slot. +If @var{self} has been assigned a sorting predicate, the array +of items will be sorted prior to the internal model update. +@end deffn + +@anchor{update-native-style} +@deffn GenericFunction update-native-style self integer => integer +This function replaces the native style flags of @var{self} with +@var{integer} and calls any additional API needed to ensure that +@var{self}'s visual representation is refreshed. The supplied +@var{integer} is returned. @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 11:39:37 2006 @@ -93,8 +93,8 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (make-instance 'gfw:button :parent btn-panel :text " ==> ") - (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Sep 5 11:39:37 2006 @@ -140,3 +140,7 @@ (defmethod text-baseline ((self button)) (widget-text-baseline self +vertical-button-text-margin+)) + +(defmethod update-native-style ((self button) flags) + (gfs::send-message (gfs:handle self) gfs::+bm-setstyle+ flags 1) + flags) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Sep 5 11:39:37 2006 @@ -195,3 +195,12 @@ (defmethod text-baseline ((self control)) (gfs:size-height (size self))) + +(defmethod update-native-style ((self control) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Sep 5 11:39:37 2006 @@ -106,16 +106,16 @@ (let ((old-widget (cancel-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hwnd (gfs:handle cancel-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style cancel-widget))) (setf style (logior style gfs::+bs-pushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style cancel-widget style))) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -144,18 +144,18 @@ (let ((old-widget (default-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style def-widget))) (setf style (logior style gfs::+bs-defpushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style def-widget style))) (defmethod gfs:dispose ((self dialog)) (reenable-top-levels) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Sep 5 11:39:37 2006 @@ -41,12 +41,10 @@ ;;; (defmethod auto-hscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+))) + (test-native-style self gfs::+es-autohscroll+)) (defmethod auto-vscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) + (test-native-style self gfs::+es-autovscroll+)) (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) @@ -84,7 +82,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) (defmethod enable-scrollbars ((self edit) horizontal vertical) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (let ((bits (get-native-style self))) (if horizontal (setf bits (logior bits gfs::+ws-hscroll+)) (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Sep 5 11:39:37 2006 @@ -117,8 +117,7 @@ (defmethod (setf image) ((image gfg:image) (label label)) (if (or (gfs:disposed-p label) (gfs:disposed-p image)) (error 'gfs:disposed-error)) - (let* ((hwnd (gfs:handle label)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style label)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+))) (flags (logior etch-flags @@ -142,8 +141,8 @@ (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) - (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) - (gfs::send-message hwnd + (update-native-style label flags)) + (gfs::send-message (gfs:handle label) gfs::+stm-setimage+ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) @@ -164,9 +163,8 @@ (init-control label)) (defmethod preferred-size ((self label) width-hint height-hint) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (* (border-width self) 2))) + (let ((bits (get-native-style self)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) (let ((image (image self))) (if image @@ -191,23 +189,18 @@ (get-widget-text self)) (defmethod (setf text) (str (self label)) - (let* ((hwnd (gfs:handle self)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style self)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) (compute-style-flags self nil nil str) (declare (ignore ex-flags)) - (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags - std-flags - +default-child-style+)))) + (update-native-style self (logior etch-flags std-flags +default-child-style+)))) (set-widget-text self str)) (defmethod text-baseline ((self label)) (let ((b-width (border-width self))) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) + (if (test-native-style self gfs::+ss-bitmap+) (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 11:39:37 2006 @@ -52,6 +52,24 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + ;;; ;;; methods ;;; @@ -151,15 +169,14 @@ ((>= height-hint 0) (setf (gfs:size-height size) height-hint)) (t - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (1+ (lb-item-height hwnd)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) - (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) - gfs::+ws-vscroll+) + (if (test-native-style self gfs::+ws-vscroll+) (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Tue Sep 5 11:39:37 2006 @@ -37,12 +37,6 @@ ;;; helper functions ;;; -(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) - (defun lb-insert-item (hwnd index label hbmp) (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) @@ -51,18 +45,6 @@ (if (< retval 0) (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) -(defun lb-width (hwnd) - (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) - (if (< width 0) - (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) - width)) - -(defun lb-item-count (hwnd) - (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) - (if (< count 0) - (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) - count)) - (defun lb-item-height (hwnd) (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) (if (< height 0) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 5 11:39:37 2006 @@ -52,9 +52,8 @@ -1)) (defun update-top-level-resizability (win same-size-flag) - (let* ((hwnd (gfs:handle win)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) - (new-flags 0)) + (let ((orig-flags (get-native-style win)) + (new-flags 0)) (cond (same-size-flag (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) @@ -192,8 +191,7 @@ (format stream "max size: ~a" (maximum-size self)))) (defmethod resizable-p ((self top-level)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + (test-native-style self gfs::+ws-thickframe+)) (defmethod (setf resizable-p) (flag (self top-level)) (let ((style (style-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Sep 5 11:39:37 2006 @@ -423,6 +423,9 @@ (defgeneric update-from-items (self) (:documentation "Rebuilds the native control's model of self from self's item list.")) +(defgeneric update-native-style (self flags) + (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Sep 5 11:39:37 2006 @@ -141,14 +141,6 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) -(defun update-native-style (widget bits) - (let ((hwnd (gfs:handle widget))) - (gfs::set-window-long hwnd gfs::+gwl-style+ bits) - (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ - gfs::+swp-nomove+ - gfs::+swp-nosize+ - gfs::+swp-nozorder+)))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) @@ -282,3 +274,15 @@ (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) (gfs:make-size :width new-width :height new-height))) + +(defun get-native-style (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+)) + +(defun get-native-exstyle (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) + +(defun test-native-style (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + +(defun test-native-exstyle (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Sep 5 11:39:37 2006 @@ -92,8 +92,7 @@ (error 'gfs:disposed-error))) (defmethod border-width ((self widget)) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (let ((bits (get-native-exstyle self))) (cond ((/= (logand bits gfs::+ws-ex-clientedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -103,8 +102,7 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) ((/= (logand bits gfs::+ws-ex-windowedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) - (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (when (logand bits gfs::+ws-border+) + (when (test-native-style self gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) @@ -434,6 +432,11 @@ (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd)))) +(defmethod update-native-style :before ((self widget) bits) + (declare (ignore bits)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 5 11:39:37 2006 @@ -152,16 +152,16 @@ (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color)) -(defmethod compute-outer-size ((win window) desired-client-size) - (let ((hwnd (gfs:handle win)) +(defmethod compute-outer-size ((self window) desired-client-size) + (let ((hwnd (gfs:handle self)) (new-size (gfs:make-size))) (gfs::with-rect (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) (if (zerop (gfs::adjust-window-rect gfs::rect-ptr - (gfs::get-window-long hwnd gfs::+gwl-style+) + (get-native-style self) (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) - (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) (gfs:size-height new-size) (- gfs::bottom gfs::top))) @@ -314,6 +314,15 @@ (outer-size self sz) sz)) +(defmethod update-native-style ((self window) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

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

05 Sep '06

Author: junrue Date: Tue Sep 5 00:26:37 2006 New Revision: 247 Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: fixed bugs in indexed-sort, got listbox selection notification working, revised list-box compute-style-flags Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Tue Sep 5 00:26:37 2006 @@ -45,7 +45,7 @@ (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) -(define-test indexed-sort-test +(define-test indexed-sort-list-test (let* ((orig1 '("zzz" "mmm" "aaa")) (result1 (gfs::indexed-sort orig1 #'string< #'identity)) (orig2 '((zzz 10) (mmm 5) (aaa 1))) @@ -59,3 +59,46 @@ (assert-true (= 5 (second (second result2)))) (assert-true (eql 'zzz (first (third result2)))) (assert-true (= 10 (second (third result2)))))) + +(defun validate-array-elements (arr1 arr2) + (assert-true (string= "aaa" (elt arr1 0))) + (assert-true (string= "mmm" (elt arr1 1))) + (assert-true (string= "zzz" (elt arr1 2))) + (assert-true (eql 'aaa (first (elt arr2 0)))) + (assert-true (= 1 (second (elt arr2 0)))) + (assert-true (eql 'mmm (first (elt arr2 1)))) + (assert-true (= 5 (second (elt arr2 1)))) + (assert-true (eql 'zzz (first (elt arr2 2)))) + (assert-true (= 10 (second (elt arr2 2))))) + +(define-test indexed-sort-non-adjustable-array-test + (let* ((orig1 (make-array 3 :initial-contents '("zzz" "mmm" "aaa"))) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 (make-array 3 :initial-contents '((zzz 10) (mmm 5) (aaa 1)))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-false (array-has-fill-pointer-p result1)) + (assert-false (array-has-fill-pointer-p result2)) + (assert-false (adjustable-array-p result1)) + (assert-false (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2))) + +(define-test indexed-sort-adjustable-array-test + (let ((orig1 (make-array 3 :adjustable t :fill-pointer 0)) + (orig2 (make-array 3 :adjustable t :fill-pointer 0))) + (loop for item in '("zzz" "mmm" "aaa") do (vector-push item orig1)) + (loop for item in '((zzz 10) (mmm 5) (aaa 1)) do (vector-push item orig2)) + (let ((result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (array-has-fill-pointer-p result1)) + (assert-true (array-has-fill-pointer-p result2)) + (assert-true (adjustable-array-p result1)) + (assert-true (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 00:26:37 2006 @@ -60,21 +60,61 @@ (defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-white*) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) +(defun lb-select (disp lb) + (declare (ignore disp)) + (print lb)) + (defun populate-list-box-test-panel () - (let* ((disp (make-instance 'widget-tester-panel-events)) - (layout (make-instance 'gfw:flow-layout)) - (panel (make-instance 'gfw:panel :dispatcher disp - :parent *widget-tester-win* - :layout layout))) - (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) - (gfW:pack panel) - panel)) + (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") + (let* ((panel-disp (make-instance 'widget-tester-panel-events)) + (lb1 nil) + (lb2 nil) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *widget-tester-win* + :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) + (lb1-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) + (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel + :callback #'lb-select + :sort-predicate #'string< + :style '(:multiple-select) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb1-panel) + (make-instance 'gfw:button :parent btn-panel :text " ==> ") + (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) + (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel + :callback #'lb-select + :style '(:extend-select :want-scrollbar) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb2-panel) + (gfw:pack outer-panel) + (let ((size (gfw:size lb1))) + (setf (gfw:maximum-size lb1) size + (gfw:minimum-size lb1) size + (gfw:maximum-size lb2) size + (gfw:minimum-size lb2) size)) + (setf (gfw:items-of lb1) *list-box-test-data*) + (gfw:update-from-items lb1) + (gfw:delete-all lb2) + outer-panel)) (defun widget-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'widget-tester-events)) (layout (make-instance 'gfw:heap-layout)) (menubar (gfw:defmenu ((:item "&File" @@ -82,8 +122,9 @@ (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout :style '(:frame))) - (setf (gfw:menu-bar *widget-tester-win*) menubar) - (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (setf (gfw:menu-bar *widget-tester-win*) menubar + (gfw:top-child-of layout) (populate-list-box-test-panel) + (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:pack *widget-tester-win*) (gfw:show *widget-tester-win* t))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Sep 5 00:26:37 2006 @@ -37,12 +37,32 @@ ;;; convenience functions ;;; +(defun recreate-array (array) + (make-array (array-dimensions array) + :adjustable (adjustable-array-p array) + :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) + (defun indexed-sort (sequence predicate key) - (let* ((tmp1 (loop for item in sequence - collect (list (funcall key item) item))) - (tmp2 (sort tmp1 predicate :key #'first))) - (loop for item in tmp2 - collect (second item)))) + (let ((result (cond + ((listp sequence) + nil) + ((vectorp sequence) + (recreate-array sequence)) + (t + (error 'gfs:toolkit-error :detail (format nil "unsupported type: ~a" sequence))))) + (tmp nil)) + (dotimes (i (length sequence)) + (let ((item (elt sequence i))) + (pushnew (list (funcall key item) item) tmp))) + (setf tmp (sort (reverse tmp) predicate :key #'first)) + (cond + ((listp result) + (setf result (loop for item in tmp collect (second item)))) + ((adjustable-array-p result) + (dotimes (i (length tmp)) (vector-push (second (elt tmp i)) result))) + (t + (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) + result)) (defun flatten (tree) (if (cl:atom tree) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 5 00:26:37 2006 @@ -126,6 +126,7 @@ (#.gfs::+en-update+ (event-modify disp widget)) (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-selchange+ (event-select disp widget)) (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) @@ -180,21 +181,17 @@ (wparam-hi (hi-word wparam)) (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner - (cond - ((zerop lparam) - (let ((item (get-item tc wparam-lo))) - (if (null item) - (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) - (unless (null (dispatcher item)) - (event-select (dispatcher item) item))))) - ((eq wparam-hi 1) - (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug - (t - (let ((widget (get-widget tc (cffi:make-pointer lparam)))) - (when (and widget (dispatcher widget)) - ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) - (dispatch-notification widget wparam-hi))))) + (if (zerop lparam) + (let ((item (get-item tc wparam-lo))) + (if (null item) + (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) + (unless (null (dispatcher item)) + (event-select (dispatcher item) item)))) + (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (when (and widget (dispatcher widget)) + (dispatch-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 00:26:37 2006 @@ -34,6 +34,25 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-extend-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-multiplesel+)))) + (logior orig-flags gfs::+lbs-extendedsel+)) + +(defun lb-multi-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-multiplesel+)) + +(defun lb-no-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-nosel+)) + +;;; ;;; methods ;;; @@ -57,26 +76,15 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags - gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+))) - - (:multiple (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags gfs::+lbs-multiplesel+))) - - (:no-select (setf std-flags (logand std-flags - (lognot (logior gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+)))) - (setf std-flags (logior std-flags gfs::+lbs-nosel+))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) + (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) @@ -97,37 +105,56 @@ (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) :before (new-items (self list-box)) + (declare (ignore new-items)) (let ((old-items (items-of self))) (dotimes (i (length old-items)) (let ((victim (elt old-items i))) (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim)))) + (gfs:dispose victim))))) + +(defmethod (setf items-of) :after (new-items (self list-box)) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) (let ((hwnd (gfs:handle self)) + (min-size (min-size-of self)) + (max-size (max-size-of self)) (size (gfs:make-size :width width-hint :height height-hint)) (b-width (* (border-width self) 2))) - (flet ((item-text (index) - (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) - (when (< width-hint 0) - (setf (gfs:size-width size) - (loop for index to (1- (lb-item-count hwnd)) - with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (gfs:size-width (widget-text-size self - (lambda (unused) - (declare (ignore unused)) - (item-text index)) - dt-flags)) - into max-width - finally (return (or max-width 0)))))) + (cond + ((and min-size (< width-hint (gfs:size-width min-size))) + (setf (gfs:size-width size) (gfs:size-width min-size))) + ((and max-size (> width-hint (gfs:size-width max-size))) + (setf (gfs:size-width size) (gfs:size-width max-size))) + ((>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (t + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) + into max-width + finally (return (or max-width 0))))))) + (cond + ((and min-size (< height-hint (gfs:size-height min-size))) + (setf (gfs:size-height size) (gfs:size-height min-size))) + ((and max-size (> height-hint (gfs:size-height max-size))) + (setf (gfs:size-height size) (gfs:size-height max-size))) + ((>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + (t + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) - (when (< height-hint 0) - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) @@ -138,16 +165,12 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) - (items (items-of self)) (hwnd (gfs:handle self))) -#| (when sort-func - (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) - (items-of self) items)) -|# + (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (progn + (let ((items (items-of self))) (lb-clear-content hwnd) (dotimes (index (length items)) (let* ((item (elt items index))

1 0

[graphic-forms-cvs] r246 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 04 Sep '06

04 Sep '06

Author: junrue Date: Mon Sep 4 16:01:46 2006 New Revision: 246 Added: trunk/src/tests/uitoolkit/widget-tester.lisp Modified: trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: lots of list-box debugging, with new widget-tester test program Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 4 16:01:46 2006 @@ -387,8 +387,8 @@ case the control will re-allocate storage as necessary). @end deffn @deffn Initarg :items -This initarg accepts a list of objects for populating the -contents of the list-box. The list-box will hold references to the +This initarg accepts a list of @ref{list-item} objects for populating +the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @@ -693,7 +693,11 @@ @anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -windows, @ref{dialog}s, or other @code{panel}s. +windows, @ref{dialog}s, or other panels. +@deffn Initarg :parent +This initarg is used to specify the @ref{parent} window of the +panel. +@end deffn @end deftp @anchor{root-window} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Sep 4 16:01:46 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:widget-tester #:textedit #:unblocked #:windlg)) @@ -87,4 +88,5 @@ (:file "layout-tester") (:file "image-tester") (:file "drawing-tester") + (:file "widget-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 4 16:01:46 2006 @@ -0,0 +1,91 @@ +;;;; +;;;; widget-tester.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.tests) + + ;; drop cookies +(defvar *list-box-test-data* '("chocolate chip" "butterscotch crunch" "peanut butter" "oatmeal" + ;; molded cookies + "butterfinger chunkies" "jam thumbprints" "cappuccino flats" + ;; pressed cookies + "langues de chat" "macaroons" "shortbread" + ;; refrigerator cookies + "brysell" "caramel" "mosaic" "praline" "toffee")) + +(defvar *widget-tester-win* nil) + +(defun widget-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *widget-tester-win*) + (setf *widget-tester-win* nil) + (gfw:shutdown 0)) + +(defclass widget-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp widget-tester-events) window) + (declare (ignore window)) + (widget-tester-exit disp nil)) + +(defclass widget-tester-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) + (declare (ignore rect)) + (setf (gfg:background-color gc) gfg:*color-white* + (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + +(defun populate-list-box-test-panel () + (let* ((disp (make-instance 'widget-tester-panel-events)) + (layout (make-instance 'gfw:flow-layout)) + (panel (make-instance 'gfw:panel :dispatcher disp + :parent *widget-tester-win* + :layout layout))) + (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) + (gfW:pack panel) + panel)) + +(defun widget-tester-internal () + (let ((disp (make-instance 'widget-tester-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'widget-tester-exit))))))) + (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (setf (gfw:menu-bar *widget-tester-win*) menubar) + (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (gfw:pack *widget-tester-win*) + (gfw:show *widget-tester-win* t))) + +(defun widget-tester () + (gfw:startup "Widget Tester" #'widget-tester-internal)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Sep 4 16:01:46 2006 @@ -48,6 +48,33 @@ (t (funcall func thing))))) +(defun copy-item-sequence (parent new-items item-class) + (let ((hwnd (gfs:handle parent)) + (tc (thread-context)) + (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (cond + ((null new-items) + replacements) + ((vectorp new-items) + (dotimes (i (length new-items)) + (let ((item (elt new-items i))) + (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements))))) + replacements) + ((listp new-items) + (loop for item in new-items + do (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements)))) + replacements) + (t + (error 'gfs:toolkit-error :detail (format nil "invalid data structure type: ~a" new-items)))))) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Sep 4 16:01:46 2006 @@ -90,3 +90,10 @@ (if (null widget) (error 'gfs:toolkit-error :detail "no owner widget")) widget))) + +(defmethod print-object ((self item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Sep 4 16:01:46 2006 @@ -76,23 +76,22 @@ for rect = (cdr k) for size = (gfs:size rect) for pnt = (gfs:location rect) - do (progn - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k))) - (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k)))))) + do (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 4 16:01:46 2006 @@ -43,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (lb-insert-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -79,7 +79,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -93,10 +93,17 @@ (init-control self) (if (and estimated-count (> estimated-count 0)) (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (if items + (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) - (declare (ignore new-items)) + (let ((old-items (items-of self))) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim)))) + (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) @@ -109,14 +116,16 @@ (setf (gfs:size-width size) (loop for index to (1- (lb-item-count hwnd)) with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (widget-text-size self - (lambda () (item-text index)) - dt-flags) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) into max-width - finally (return max-width))))) + finally (return (or max-width 0)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) - (incf (gfs:size-width size) b-width)) + (incf (gfs:size-width size) (+ b-width 4))) (when (< height-hint 0) (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) @@ -131,16 +140,18 @@ (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) +#| (when sort-func (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) +|# (enable-redraw self nil) (unwind-protect (progn (lb-clear-content hwnd) - (loop for item in items - for index = 0 then (1+ index) - do (progn - (setf (index-of item) index) - (append-item self item (dispatcher self))))) + (dotimes (index (length items)) + (let* ((item (elt items index)) + (text (call-text-provider self (data-of item)))) + (setf (index-of item) index) + (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Mon Sep 4 16:01:46 2006 @@ -47,8 +47,9 @@ (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + (let ((retval (gfs::send-message hwnd gfs::+lb-insertstring+ index (cffi:pointer-address str-ptr)))) + (if (< retval 0) + (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -88,8 +89,16 @@ (defmethod gfs:dispose ((self list-item)) (let ((index (index-of self)) - (owner (owner self))) - (if owner - (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (howner (gfs:handle self))) + (if howner + (gfs::send-message howner gfs::+lb-deletestring+ index 0)) (setf (index-of self) 0)) (call-next-method)) + +(defmethod print-object ((self list-item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "index: ~d " (index-of self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Sep 4 16:01:46 2006 @@ -183,7 +183,7 @@ :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget item-manager) +(defclass list-box (control item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Sep 4 16:01:46 2006 @@ -310,7 +310,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a~%" (dispatcher self)))) + (format stream "dispatcher: ~a" (dispatcher self)))) (defmethod redo-available-p :before ((self widget)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r245 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 01 Sep '06

01 Sep '06

Author: junrue Date: Fri Sep 1 00:27:49 2006 New Revision: 245 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented wrappers for list box messages, implemented list-box preferred-size method, some light refactoring of other controls Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Fri Sep 1 00:27:49 2006 @@ -37,7 +37,7 @@ @end defun @anchor{event-activate} -@deffn GenericFunction event-activate dispatcher widget +@deffn GenericFunction event-activate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and @@ -64,7 +64,7 @@ @end table @end deffn -@deffn GenericFunction event-close dispatcher widget +@deffn GenericFunction event-close @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being closed by the user. Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close events. @@ -76,7 +76,7 @@ @end deffn @anchor{event-deactivate} -@deffn GenericFunction event-deactivate dispatcher widget +@deffn GenericFunction event-deactivate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being deactivated, meaning that some other object has been made active. This event only applies to @ref{top-level} @ref{window}s or @@ -88,7 +88,21 @@ @end table @end deffn -@deffn GenericFunction event-dispose dispatcher widget +@anchor{event-default-action} +@deffn GenericFunction event-default-action @ref{event-dispatcher} @ref{widget} +Implement this method to respond to a @ref{default action}, for +example when the user double-clicks on a @ref{list-box} @ref{item}, or +presses @sc{enter} while the keyboard focus is in an @ref{edit} +control. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} for which the default action was invoked. +@end table +@end deffn + +@anchor{event-dispose} +@deffn GenericFunction event-dispose @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}; this event is not associated with garbage collection). This event function is called while the contents of @var{widget} are still @@ -101,7 +115,7 @@ @end deffn @anchor{event-focus-gain} -@deffn GenericFunction event-focus-gain dispatcher widget +@deffn GenericFunction event-focus-gain @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} gaining keyboard focus. @table @var @event-dispatcher-arg @@ -111,7 +125,7 @@ @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-loss dispatcher widget +@deffn GenericFunction event-focus-loss @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} losing keyboard focus. @table @var @event-dispatcher-arg @@ -120,7 +134,7 @@ @end table @end deffn -@deffn GenericFunction event-key-down dispatcher widget keycode char +@deffn GenericFunction event-key-down @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being pressed within @var{widget}. @table @var @@ -135,7 +149,7 @@ @end table @end deffn -@deffn GenericFunction event-key-up dispatcher widget keycode char +@deffn GenericFunction event-key-up @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being released within @var{widget}. @table @var @event-dispatcher-arg @@ -150,7 +164,7 @@ @end deffn @anchor{event-modify} -@deffn GenericFunction event-modify dispatcher widget +@deffn GenericFunction event-modify @ref{event-dispatcher} @ref{widget} Implement this method to respond to changes due to user input within @ref{widget}, for example when the user types text inside an @ref{edit} @ref{control}. @@ -161,7 +175,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-double dispatcher widget point button +@deffn GenericFunction event-mouse-double @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button double-click within @var{widget}. @table @var @event-dispatcher-arg @@ -172,7 +186,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-down dispatcher widget point button +@deffn GenericFunction event-mouse-down @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button click within @var{widget}. @table @var @event-dispatcher-arg @@ -183,7 +197,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-move dispatcher widget point button +@deffn GenericFunction event-mouse-move @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse move event within @var{widget}. @table @var @event-dispatcher-arg @@ -194,7 +208,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-up dispatcher widget point button +@deffn GenericFunction event-mouse-up @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button being released within @var{widget}. @table @var @@ -206,7 +220,7 @@ @end table @end deffn -@deffn GenericFunction event-move dispatcher widget point +@deffn GenericFunction event-move @ref{event-dispatcher} @ref{widget} @ref{point} Implement this method to respond to @var{widget} being moved within its @ref{parent}'s coordinate system. @table @var @@ -219,7 +233,7 @@ @end deffn @anchor{event-paint} -@deffn GenericFunction event-paint dispatcher widget gc rect +@deffn GenericFunction event-paint @ref{event-dispatcher} @ref{widget} @ref{graphics-context} @ref{rectangle} Implement this method to respond to system requests to repaint @var{widget}. @table @var @event-dispatcher-arg @@ -233,7 +247,7 @@ @end table @end deffn -@deffn GenericFunction event-resize dispatcher widget size type +@deffn GenericFunction event-resize @ref{event-dispatcher} @ref{widget} size type Implement this method to respond to @var{widget} being resized. @table @var @event-dispatcher-arg @@ -258,7 +272,7 @@ @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher widget +@deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Fri Sep 1 00:27:49 2006 @@ -40,6 +40,17 @@ accept user input and possibly generate notification events based on such input.@* +@item default action +@anchor{default action} +@cindex default action +Conceptually, a default action is a secondary event initiated by user +input that is a logical follow-up to a previous event. Examples of +such user gestures include double-clicking an item in a list box +control, or pressing @sc{enter} when an edit control has the keyboard +focus. The response to a default action makes use of context +established by the preceding event (e.g., the selection set by an +initial click becomes the context for the double-click response).@* + @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 1 00:27:49 2006 @@ -70,7 +70,7 @@ @end macro @macro event-dispatcher-arg -@item dispatcher +@item event-dispatcher The @ref{event-dispatcher} to process this event. @end macro Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Sep 1 00:27:49 2006 @@ -556,6 +556,13 @@ (defconstant +lb-multipleaddstring+ #x01B1) (defconstant +lb-getlistboxinfo+ #x01B2) +(defconstant +lbn-errspace+ -2) +(defconstant +lbn-selchange+ 1) +(defconstant +lbn-dblclk+ 2) +(defconstant +lbn-selcancel+ 3) +(defconstant +lbn-setfocus+ 4) +(defconstant +lbn-killfocus+ 5) + (defconstant +lbs-notify+ #x0001) (defconstant +lbs-sort+ #x0002) (defconstant +lbs-noredraw+ #x0004) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 1 00:27:49 2006 @@ -97,7 +97,7 @@ (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) - (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+)) (size (gfs:make-size)) (b-width (* (border-width self) 2)) (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 1 00:27:49 2006 @@ -115,7 +115,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0)) (defmethod preferred-size ((self edit) width-hint height-hint) - (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (let ((text-size (widget-text-size self #'text (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) (size (gfs:make-size)) (b-width (* (border-width self) 2))) (if (>= width-hint 0) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Fri Sep 1 00:27:49 2006 @@ -58,6 +58,11 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) +(defgeneric event-default-action (dispatcher widget) + (:documentation "Implement this to respond to the widget-specific default action.") + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) + (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") (:method (dispatcher widget) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Sep 1 00:27:49 2006 @@ -120,10 +120,13 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget)) - (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) - (#.gfs::+en-update+ (event-modify disp widget))))) + (0 (event-select disp widget)) + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget)) + (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) + (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 1 00:27:49 2006 @@ -178,7 +178,7 @@ (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf size (widget-text-size self flags)) + (setf size (widget-text-size self #'text flags)) (if (>= width-hint 0) (setf (gfs:size-width size) width-hint) (incf (gfs:size-width size) b-width)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 1 00:27:49 2006 @@ -34,17 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; helper functions -;;; - -(defun insert-list-item (hwnd index label hbmp) - (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box - (let ((text (or label ""))) - (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) - -;;; ;;; methods ;;; @@ -54,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -103,16 +92,41 @@ (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) (if (and estimated-count (> estimated-count 0)) - (gfs::send-message (gfs:handle self) - gfs::+lb-initstorage+ - estimated-count - (* estimated-count +estimated-text-size+))) + (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) +(defmethod preferred-size ((self list-box) width-hint height-hint) + (let ((hwnd (gfs:handle self)) + (size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width self) 2))) + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (when (< width-hint 0) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (widget-text-size self + (lambda () (item-text index)) + dt-flags) + into max-width + finally (return max-width))))) + (if (zerop (gfs:size-width size)) + (setf (gfs:size-width size) +default-widget-width+) + (incf (gfs:size-width size) b-width)) + (when (< height-hint 0) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) + (if (zerop (gfs:size-height size)) + (setf (gfs:size-height size) +default-widget-height+) + (incf (gfs:size-height size) b-width)) + (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) + gfs::+ws-vscroll+) + (incf (gfs:size-width size) (vertical-scrollbar-width))) + size)) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (items (items-of self)) @@ -123,7 +137,7 @@ (enable-redraw self nil) (unwind-protect (progn - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (lb-clear-content hwnd) (loop for item in items for index = 0 then (1+ index) do (progn Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 1 00:27:49 2006 @@ -34,6 +34,55 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-insert-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + +(defun lb-item-height (hwnd) + (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) + (if (< height 0) + (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) + height)) + +(defun lb-item-text (hwnd index &optional buffer-size) + (if (or (null buffer-size) (<= buffer-size 0)) + (setf buffer-size (lb-item-text-length hwnd index))) + (cffi:with-foreign-pointer-as-string (str-ptr (1+ buffer-size)) + (if (< (gfs::send-message hwnd gfs::+lb-gettext+ index (cffi:pointer-address str-ptr)) 0) + (error 'gfs:win32-error :detail "LB_GETTEXT failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Sep 1 00:27:49 2006 @@ -95,5 +95,7 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) - (defconstant +estimated-text-size+ 32)) ;; bytes + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +default-widget-width+ 64) + (defconstant +default-widget-height+ 64) + (defconstant +estimated-text-size+ 32)) ; bytes Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 1 00:27:49 2006 @@ -190,18 +190,30 @@ (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop))))) +(defun horizontal-scrollbar-height () + (gfs::get-system-metrics gfs::+sm-cyhscroll+)) + +(defun horizontal-scrollbar-arrow-width () + (gfs::get-system-metrics gfs::+sm-cxhscroll+)) + +(defun vertical-scrollbar-arrow-height () + (gfs::get-system-metrics gfs::+sm-cyvscroll+)) + +(defun vertical-scrollbar-width () + (gfs::get-system-metrics gfs::+sm-cxvscroll+)) + (defun set-widget-text (w str) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags) +(defun widget-text-size (widget text-func dt-flags) (let ((hwnd (gfs:handle widget)) (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (gfg::text-bounds hdc (text widget) dt-flags 0))))) + (gfg::text-bounds hdc (funcall text-func widget) dt-flags 0))))) ;;; ;;; This algorithm adapted from the calculate_best_bounds() @@ -233,8 +245,8 @@ ;; use scrollbar system metric values as a rough approximation ;; (return-from check-box-size - (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) - :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + (gfs:make-size :width (vertical-scrollbar-width) + :height (vertical-scrollbar-arrow-height)))) (unwind-protect (cffi:with-foreign-object (bm-ptr 'gfs::bitmap)

1 0

[graphic-forms-cvs] r244 - in trunk: . docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Aug '06

30 Aug '06

Author: junrue Date: Wed Aug 30 00:57:25 2006 New Revision: 244 Added: trunk/src/uitoolkit/widgets/list-item.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: refactored more of menu-item, implemented new list-item class Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 30 00:57:25 2006 @@ -104,17 +104,21 @@ @end deffn @end macro -@macro begin-control-subclass{classname,descr,callbackname} -@anchor{\classname\} -@deftp Class \classname\ callback-event-name -\descr\ -@table @var +@macro callback-event-name-slot{callbackname} @item callback-event-name This is an @code{(:allocation :class)} slot that holds the symbol @sc{@ref{\callbackname\}} identifying the event generic function to be implemented on behalf of the application when a function is supplied for the @code{:callback} initarg. See @ref{event-source} for more details on this slot. +@end macro + +@macro begin-control-subclass{classname,descr,callbackname} +@anchor{\classname\} +@deftp Class \classname\ callback-event-name +\descr\ +@table @var +@callback-event-name-slot{\callbackname\} @end table @end macro Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Wed Aug 30 00:57:25 2006 @@ -65,6 +65,7 @@ interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var +@callback-event-name-slot{event-select} @item data A reference to the application-defined object to be wrapped by the item. @@ -120,6 +121,16 @@ @end deffn @end deftp +@anchor{list-item} +@deftp Class list-item index +A subclass of @ref{item} representing an element of a @ref{list-box}. +@table @var +@item index +This is an internal value representing the position of the item +within the list-box control. +@end table +@end deftp + @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 30 00:57:25 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-item") (:file "list-box") (:file "menu") (:file "menu-item") Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Aug 30 00:57:25 2006 @@ -85,6 +85,12 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) +(defmethod gfs:dispose ((self item-manager)) + (let ((items (items-of self)) + (tc (thread-context))) + (dotimes (i (length items)) + (delete-tc-item tc (elt items i))))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Wed Aug 30 00:57:25 2006 @@ -33,16 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defun create-item-with-callback (howner thing disp) +;;; +;;; helper functions +;;; + +(defun create-item-with-callback (howner class-symbol thing disp) (let ((item nil) (id (increment-item-id (thread-context)))) (cond ((null disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) ((functionp disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -51,6 +55,10 @@ (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) +;;; +;;; methods +;;; + (defmethod check :before ((self item) flag) (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) @@ -59,3 +67,26 @@ (defmethod checked-p :before ((self item)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) + +(defmethod gfs:dispose ((self item)) + (setf (dispatcher self) nil) + (delete-tc-item (thread-context) self) + (setf (data-of self) nil) + (setf (item-id self) 0) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) + (make-instance (define-dispatcher (class-name (class-of self)) callback))))) + +(defmethod owner ((self item)) + (let ((hwnd (gfs:handle self))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:toolkit-error :detail "null owner widget handle")) + (let ((widget (get-widget (thread-context) hwnd))) + (if (null widget) + (error 'gfs:toolkit-error :detail "no owner widget")) + widget))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Aug 30 00:57:25 2006 @@ -53,7 +53,7 @@ (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol thing disp))) + (item (create-item-with-callback hcontrol 'list-item thing disp))) (insert-list-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) @@ -125,5 +125,8 @@ (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item (dispatcher self)))) + for index = 0 then (1+ index) + do (progn + (setf (index-of item) index) + (append-item self item (dispatcher self))))) (enable-redraw self t)))) Added: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-item.lisp Wed Aug 30 00:57:25 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; list-item.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 gfs:dispose ((self list-item)) + (let ((index (index-of self)) + (owner (owner self))) + (if owner + (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (setf (index-of self) 0)) + (call-next-method)) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Wed Aug 30 00:57:25 2006 @@ -170,65 +170,47 @@ ;;; methods ;;; -(defmethod check ((it menu-item) flag) - (let ((hmenu (gfs:handle it))) - (check-menuitem hmenu (item-id it) flag))) +(defmethod check ((self menu-item) flag) + (let ((hmenu (gfs:handle self))) + (check-menuitem hmenu (item-id self) flag))) -(defmethod checked-p ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod checked-p ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (is-menuitem-checked hmenu (item-id it)))) + (is-menuitem-checked hmenu (item-id self)))) -(defmethod gfs:dispose ((it menu-item)) - (setf (dispatcher it) nil) - (delete-tc-item (thread-context) it) - (let ((id (item-id it)) - (owner (owner it))) +(defmethod gfs:dispose ((self menu-item)) + (let ((id (item-id self)) + (owner (owner self))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) - (let* ((index (item-index owner it)) + (let* ((index (item-index owner self)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfs:dispose child-menu)))) - (setf (item-id it) 0) - (setf (slot-value it 'gfs:handle) nil))) + (gfs:dispose child-menu))))) + (call-next-method)) -(defmethod enable ((it menu-item) flag) +(defmethod enable ((self menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfs:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle self) (item-id self) bits))) -(defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) +(defmethod enabled-p ((self menu-item)) + (= (logand (get-menuitem-state (gfs:handle self) (item-id self)) gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) - (when callback - (unless (typep callback 'function) - (error 'gfs:toolkit-error :detail ":callback value must be a function")) - (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) - -(defmethod owner ((it menu-item)) - (let ((hmenu (gfs:handle it))) - (if (gfs:null-handle-p hmenu) - (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no owner menu")) - m))) - -(defmethod text ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod text ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (get-menuitem-text hmenu (item-id it)))) + (get-menuitem-text hmenu (item-id self)))) -(defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod (setf text) (str (self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (set-menuitem-text hmenu (item-id it) str))) + (set-menuitem-text hmenu (item-id self) str))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Aug 30 00:57:25 2006 @@ -93,7 +93,7 @@ (defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu thing disp)) + (item (create-item-with-callback hmenu 'menu-item thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) @@ -141,11 +141,13 @@ (delete-widget tc (gfs:handle menu)) (delete-tc-item tc item))) -(defmethod gfs:dispose ((m menu)) - (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfs:handle m))) - (delete-widget (thread-context) hwnd) - (if (not (gfs:null-handle-p hwnd)) +(defmethod gfs:dispose ((self menu)) + (unless (null (dispatcher self)) + (event-dispose (dispatcher self) self)) + (visit-menu-tree self #'menu-cleanup-callback) + (let ((hwnd (gfs:handle self))) + (when (not (gfs:null-handle-p hwnd)) + (delete-widget (thread-context) hwnd) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Aug 30 00:57:25 2006 @@ -90,8 +90,14 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) +(defclass list-item (item) + ((index + :accessor index-of + :initform 0)) + (:documentation "A subclass of item representing an element of a list-box.")) + (defclass menu-item (item) () - (:documentation "A subtype of item representing a menu item.")) + (:documentation "A subclass of item representing a menu item.")) (defclass widget (event-source) ((style

1 0

[graphic-forms-cvs] r243 - in trunk: docs/manual src src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Aug '06

30 Aug '06

Author: junrue Date: Tue Aug 29 21:29:32 2006 New Revision: 243 Modified: trunk/docs/manual/widget-types.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented list-box version of append-item, renamed items accessor to items-of Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 21:29:32 2006 @@ -74,26 +74,29 @@ @end deftp @anchor{item-manager} -@deftp Class item-manager collator image-provider items text-provider +@deftp Class item-manager image-provider items sort-predicate text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. @table @var -@item collator -This slot holds a predicate function of two arguments returning a -@sc{boolean}, for the purpose of ordering @var{items}. The arguments -passed are application-defined objects. Note that not all subclasses -make use of this feature. @item image-provider This slot holds a function accepting one argument and returning an -instance of @ref{image}. The default implementation simply -returns @sc{nil}. +instance of @ref{image}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation simply returns @sc{nil}. @item items -An @sc{adjustable} @sc{vector} containing @ref{item}s representing -sub-elements. +An @sc{adjustable} @sc{vector} containing instances of an +@ref{item} subclass appropriate for the actual @ref{widget}. +Each such item wraps an application-supplied data object. @item text-provider This slot holds a function accepting one argument and returning a -@sc{string}. The default implementation checks whether the argument -is already a @sc{string}, and if so just returns it; otherwise it -calls @sc{format}. +@sc{string}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation checks whether the argument is a @sc{string}, +and if so just returns it; otherwise it calls @sc{format}. +@item sort-predicate +This slot holds a predicate function of two arguments returning a +@sc{boolean}, for the purpose of ordering the members of the @var{items} +list. The actual arguments passed are the application-supplied objects. +Note that not all subclasses make use of this feature. @end table @end deftp @@ -364,6 +367,14 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} +@deffn Initarg :estimated-count +This initarg accepts a positive integer value indicating the expected +number of items that the list-box will hold. If supplied, it enables +an optimization in storage allocation by the underlying native control. +As the name of the initarg implies, this is an estimate, which may be +too high (in which case heap space may be wasted) or too low (in which +case the control will re-allocate storage as necessary). +@end deffn @deffn Initarg :items This initarg accepts a list of objects for populating the contents of the list-box. The list-box will hold references to the Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@ (defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) - (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) + (gfw:enable (elt (gfw:items-of menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items-of menu) 3) (> (length (gfw:text *textedit-control*)) 0))) (defun textedit-file-new (disp item) (declare (ignore disp item)) @@ -97,7 +97,7 @@ (declare (ignore disp)) (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) - (let ((items (gfw:items menu)) + (let ((items (gfw:items-of menu)) (text (gfw:text *textedit-control*)) (text-sel (gfw:selection-span *textedit-control*))) (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 21:29:32 2006 @@ -438,7 +438,7 @@ #:item-height #:item-id #:item-index - #:items + #:items-of #:key-down-p #:key-toggled-p #:label Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@ (defun find-checked-item (disp menu) (declare (ignore disp)) - (dotimes (i (length (gfw:items menu))) - (let ((item (elt (gfw:items menu) i))) + (dotimes (i (length (gfw:items-of menu))) + (let ((item (elt (gfw:items-of menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return))))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Aug 29 21:29:32 2006 @@ -213,7 +213,7 @@ (defun manage-file-menu (disp menu) (declare (ignore disp)) - (let ((item (elt (gfw:items menu) 0))) + (let ((item (elt (gfw:items-of menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) (defun manage-timer (disp item) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Aug 29 21:29:32 2006 @@ -211,8 +211,8 @@ (defun check-flow-orient-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) - (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) + (gfw:check (elt (gfw:items-of menu) 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (elt (gfw:items-of menu) 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item) (declare (ignorable disp item)) @@ -253,7 +253,7 @@ (defun enable-flow-spacing-items (disp menu) (declare (ignore disp)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) - (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> spacing 0)))) (defun decrease-flow-spacing (disp item) (declare (ignore disp item)) @@ -273,22 +273,22 @@ (defun enable-left-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:left-margin-of layout) 0)))) (defun enable-top-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:top-margin-of layout) 0)))) (defun enable-right-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:right-margin-of layout) 0)))) (defun enable-bottom-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:bottom-margin-of layout) 0)))) (defun inc-left-flow-margin (disp item) (declare (ignore disp item)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Aug 29 21:29:32 2006 @@ -180,7 +180,7 @@ (if owner (cond ((zerop lparam) - (let ((item (get-menuitem tc wparam-lo))) + (let ((item (get-item tc wparam-lo))) (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) @@ -208,7 +208,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) - (item (get-menuitem tc (lo-word wparam)))) + (item (get-item tc (lo-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Tue Aug 29 21:29:32 2006 @@ -58,10 +58,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self item-manager)) - (let ((items (items self))) + (let ((items (items-of self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t))) (defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -69,9 +69,9 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (items self)) + (let* ((items (items-of self)) (it (elt items index))) - (setf (items self) (remove it items :test #'items-equal-p)) + (setf (items-of self) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -91,7 +91,7 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items self) :test #'items-equal-p))) + (let ((pos (position it (items-of self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Tue Aug 29 21:29:32 2006 @@ -32,7 +32,22 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) - + +(defun create-item-with-callback (howner thing disp) + (let ((item nil) + (id (increment-item-id (thread-context)))) + (cond + ((null disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + ((functionp disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + ((typep disp 'gfw:event-dispatcher) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) + item)) + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 21:29:32 2006 @@ -34,9 +34,31 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun insert-list-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +;;; ;;; methods ;;; +(defmethod append-item ((self list-box) thing disp &optional disabled checked) + (declare (ignore disabled checked)) + (let* ((tc (thread-context)) + (hcontrol (gfs:handle self)) + (text (call-text-provider self thing)) + (item (create-item-with-callback hcontrol thing disp))) + (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (put-item tc item) + (vector-push-extend item (items-of self)) + item)) + (defmethod compute-style-flags ((self list-box) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ @@ -68,7 +90,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -80,23 +102,28 @@ (increment-widget-id (thread-context))))) (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message (gfs:handle self) + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))) (update-from-items self)) -(defmethod (setf items) :after (new-items (self list-box)) +(defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) (defmethod update-from-items ((self list-box)) - (let ((collator (collator-of self)) + (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) - (when collator - (setf items (gfs::indexed-sort items collator (lambda (it) (data-of it))) + (when sort-func + (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) (enable-redraw self nil) (unwind-protect (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item ???))) + do (append-item self item (dispatcher self)))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Aug 29 21:29:32 2006 @@ -166,20 +166,6 @@ (error 'gfs:win32-error :detail "set-menu-item-info failed")) (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) -(defun create-menuitem-with-callback (hmenu thing disp) - (let ((item nil)) - (cond - ((null disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu))) - ((functionp disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) - ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp))) - (t - (error 'gfs:toolkit-error - :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) - item)) - ;;; ;;; methods ;;; @@ -196,7 +182,7 @@ (defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) - (delete-menuitem (thread-context) it) + (delete-tc-item (thread-context) it) (let ((id (item-id it)) (owner (owner it))) (unless (null owner) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Aug 29 21:29:32 2006 @@ -37,7 +37,7 @@ ;;; helper functions ;;; -(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked) +(defun append-menuitem (hmenu mid label hbmp hchildmenu disabled checked) (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) @@ -79,8 +79,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (length (items menu))) - (let ((it (elt (items menu) index)) + (dotimes (index (length (items-of menu))) + (let ((it (elt (items-of menu) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -90,43 +90,39 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (hmenu (gfs:handle owner)) - (item (create-menuitem-with-callback hmenu thing disp)) - (text (call-text-provider owner thing))) - (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (hmenu (gfs:handle self)) + (item (create-item-with-callback hmenu thing disp)) + (text (call-text-provider self thing))) + (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) + (put-item tc item) + (vector-push-extend item (items-of self)) item)) -(defmethod append-separator ((owner menu)) - (if (gfs:disposed-p owner) +(defmethod append-separator ((self menu)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (howner (gfs:handle owner)) - (item (make-instance 'menu-item :handle howner))) - (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (id (increment-item-id tc)) + (hmenu (gfs:handle self)) + (item (make-instance 'menu-item :handle hmenu :item-id id))) + (append-menuitem hmenu id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) + (put-item tc item) + (vector-push-extend item (items-of self)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked) - (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) +(defmethod append-submenu ((self menu) text (submenu menu) disp &optional disabled checked) + (if (or (gfs:disposed-p self) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (hparent (gfs:handle parent)) + (id (increment-item-id tc)) + (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent))) - (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items parent)) + (item (make-instance 'menu-item :handle hparent :item-id id))) + (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (put-item tc item) + (vector-push-extend item (items-of self)) (put-widget tc submenu) (cond ((null disp)) @@ -143,7 +139,7 @@ (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) (delete-widget tc (gfs:handle menu)) - (delete-menuitem tc item))) + (delete-tc-item tc item))) (defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Aug 29 21:29:32 2006 @@ -41,10 +41,10 @@ (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) + (items-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) - (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-item-id :initform 10000 :reader next-item-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -108,10 +108,10 @@ (defgeneric put-kbdnav-widget (self widget)) (defgeneric delete-kbdnav-widget (self widget)) (defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-menuitem (self id)) -(defgeneric put-menuitem (self item)) -(defgeneric delete-menuitem (self item)) -(defgeneric increment-menuitem-id (self)) +(defgeneric get-item (self id)) +(defgeneric put-item (self item)) +(defgeneric delete-tc-item (self item)) +(defgeneric increment-item-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -202,27 +202,27 @@ (return-from intercept-kbdnav-message widget)))) nil) -(defmethod get-menuitem ((tc thread-context) id) - "Returns the menu item identified by id." - (gethash id (slot-value tc 'menuitems-by-id))) - -(defmethod put-menuitem ((tc thread-context) (it menu-item)) - "Stores a menu item using its id as the key." - (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) +(defmethod get-item ((tc thread-context) id) + "Returns the item identified by id." + (gethash id (slot-value tc 'items-by-id))) + +(defmethod put-item ((tc thread-context) (it item)) + "Stores an item using its id as the key." + (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it)) -(defmethod delete-menuitem ((tc thread-context) (it menu-item)) - "Removes the menu item using its id as the key." +(defmethod delete-tc-item ((tc thread-context) (it item)) + "Removes the item using its id as the key." (maphash #'(lambda (k v) (declare (ignore v)) (if (eql k (item-id it)) - (remhash k (slot-value tc 'menuitems-by-id)))) - (slot-value tc 'menuitems-by-id))) + (remhash k (slot-value tc 'items-by-id)))) + (slot-value tc 'items-by-id))) -(defmethod increment-menuitem-id ((tc thread-context)) +(defmethod increment-item-id ((tc thread-context)) "Return the next menu item ID; also increment the internal value." - (let ((id (next-menuitem-id tc))) - (incf (slot-value tc 'next-menuitem-id)) + (let ((id (next-item-id tc))) + (incf (slot-value tc 'next-item-id)) id)) (defmethod get-timer ((tc thread-context) id) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Aug 29 21:29:32 2006 @@ -159,12 +159,12 @@ (:documentation "This class represents the standard font dialog.")) (defclass item-manager () - ((collator - :accessor collator-of - :initarg :collator + ((sort-predicate + :accessor sort-predicate-of + :initarg :sort-predicate :initform nil) (items - :accessor items + :accessor items-of ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) (text-provider Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Tue Aug 29 21:29:32 2006 @@ -95,4 +95,5 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))) + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +estimated-text-size+ 32)) ;; bytes Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Aug 29 21:29:32 2006 @@ -420,6 +420,9 @@ (defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) +(defgeneric update-from-items (self) + (:documentation "Rebuilds the native control's model of self from self's item list.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise."))

1 0

[graphic-forms-cvs] r242 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Aug '06

29 Aug '06

Author: junrue Date: Tue Aug 29 15:28:42 2006 New Revision: 242 Added: trunk/src/uitoolkit/widgets/list-box.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: continued work on item-manager refactoring and list-box implementation Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 29 15:28:42 2006 @@ -1,5 +1,7 @@ +. Implemented GFW:ENABLE-REDRAW to enable applications to temporarily + disable (and later re-enable) drawing of widget content. ============================================================================== Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Aug 29 15:28:42 2006 @@ -186,24 +186,34 @@ and @ref{auto-vscroll-p}. @end deffn +@anchor{enable-layout} @deffn GenericFunction enable-layout self flag -Cause the object to allow or disallow layout management. +Passing @sc{nil} for @var{flag} disables layout management in @var{self}; +any non-@sc{nil} value enables it. @end deffn -@deffn GenericFunction enabled-p self -Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. +@anchor{enable-redraw} +@deffn GenericFunction enable-redraw self flag +Passing @sc{nil} for @var{flag} prevents @var{self} from being redrawn +when its client area is invalidated; any non-@sc{nil} value enables +drawing and also invalidates the client area. @end deffn @anchor{enable-scrollbars} @deffn GenericFunction enable-scrollbars self horizontal vertical -Specifying T for @code{horizontal} (@code{vertical}) reveals a +Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of -@code{self}. Specifying @sc{nil} hides the scrollbar. These flags do +@var{self}. Specifying @sc{nil} hides the scrollbar. These flags do not affect scrolling behavior in @code{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn +@anchor{enabled-p} +@deffn GenericFunction enabled-p self +Returns @sc{t} if @var{self} is enabled; @sc{nil} otherwise. +@end deffn + @anchor{file-dialog-paths} @defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @@ -533,6 +543,14 @@ before this function returns. @end deffn +@anchor{update-from-items} +@deffn GenericFunction update-from-items self +Synchronizes @var{self}'s internal model (i.e., a native control's +data structures) with the list from the @var{items} slot +after that list has been sorted. Application code typically does not +need to call this function. +@end deffn + @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @code{self} has been configured to display a vertical Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 15:28:42 2006 @@ -74,9 +74,14 @@ @end deftp @anchor{item-manager} -@deftp Class item-manager image-provider items text-provider +@deftp Class item-manager collator image-provider items text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. @table @var +@item collator +This slot holds a predicate function of two arguments returning a +@sc{boolean}, for the purpose of ordering @var{items}. The arguments +passed are application-defined objects. Note that not all subclasses +make use of this feature. @item image-provider This slot holds a function accepting one argument and returning an instance of @ref{image}. The default implementation simply @@ -359,14 +364,8 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} -@deffn Initarg :collator -This initarg accepts a predicate function of two arguments -returning a @sc{boolean}, for the purpose of ordering the list-box -items. The arguments passed are the application-supplied data objects -used to populate the list-box. -@end deffn -@deffn Initarg :initial-items -This initarg accepts a list of objects for initially populating the +@deffn Initarg :items +This initarg accepts a list of objects for populating the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Aug 29 15:28:42 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-box") (:file "menu") (:file "menu-item") (:file "menu-language") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 15:28:42 2006 @@ -259,6 +259,7 @@ #:item-manager #:layout-managed #:layout-manager + #:list-box #:menu #:menu-item #:panel @@ -521,6 +522,7 @@ #:trim-sizes #:undo-available-p #:update + #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Tue Aug 29 15:28:42 2006 @@ -44,3 +44,18 @@ (assert-true (> (gfs:size-width size)) 0) (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) + +(define-test indexed-sort-test + (let* ((orig1 '("zzz" "mmm" "aaa")) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 '((zzz 10) (mmm 5) (aaa 1))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (string= "aaa" (first result1))) + (assert-true (string= "mmm" (second result1))) + (assert-true (string= "zzz" (third result1))) + (assert-true (eql 'aaa (first (first result2)))) + (assert-true (= 1 (second (first result2)))) + (assert-true (eql 'mmm (first (second result2)))) + (assert-true (= 5 (second (second result2)))) + (assert-true (eql 'zzz (first (third result2)))) + (assert-true (= 10 (second (third result2)))))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Aug 29 15:28:42 2006 @@ -38,6 +38,7 @@ ;;; (defparameter *button-classname* "button") (defparameter *edit-classname* "edit") +(defparameter *listbox-classname* "listbox") (defparameter *static-classname* "static") ;;; @@ -512,6 +513,66 @@ (defconstant +image-cursor+ 2) (defconstant +image-enhmetafile+ 3) +(defconstant +lb-addstring+ #x0180) +(defconstant +lb-insertstring+ #x0181) +(defconstant +lb-deletestring+ #x0182) +(defconstant +lb-selitemrangeex+ #x0183) +(defconstant +lb-resetcontent+ #x0184) +(defconstant +lb-setsel+ #x0185) +(defconstant +lb-setcursel+ #x0186) +(defconstant +lb-getsel+ #x0187) +(defconstant +lb-getcursel+ #x0188) +(defconstant +lb-gettext+ #x0189) +(defconstant +lb-gettextlen+ #x018A) +(defconstant +lb-getcount+ #x018B) +(defconstant +lb-selectstring+ #x018C) +(defconstant +lb-dir+ #x018D) +(defconstant +lb-gettopindex+ #x018E) +(defconstant +lb-findstring+ #x018F) +(defconstant +lb-getselcount+ #x0190) +(defconstant +lb-getselitems+ #x0191) +(defconstant +lb-settabstops+ #x0192) +(defconstant +lb-gethorizontalextent+ #x0193) +(defconstant +lb-sethorizontalextent+ #x0194) +(defconstant +lb-setcolumnwidth+ #x0195) +(defconstant +lb-addfile+ #x0196) +(defconstant +lb-settopindex+ #x0197) +(defconstant +lb-getitemrect+ #x0198) +(defconstant +lb-getitemdata+ #x0199) +(defconstant +lb-setitemdata+ #x019A) +(defconstant +lb-selitemrange+ #x019B) +(defconstant +lb-setanchorindex+ #x019C) +(defconstant +lb-getanchorindex+ #x019D) +(defconstant +lb-setcaretindex+ #x019E) +(defconstant +lb-getcaretindex+ #x019F) +(defconstant +lb-setitemheight+ #x01A0) +(defconstant +lb-getitemheight+ #x01A1) +(defconstant +lb-findstringexact+ #x01A2) +(defconstant +lb-setlocale+ #x01A5) +(defconstant +lb-getlocale+ #x01A6) +(defconstant +lb-setcount+ #x01A7) +(defconstant +lb-initstorage+ #x01A8) +(defconstant +lb-itemfrompoint+ #x01A9) +(defconstant +lb-multipleaddstring+ #x01B1) +(defconstant +lb-getlistboxinfo+ #x01B2) + +(defconstant +lbs-notify+ #x0001) +(defconstant +lbs-sort+ #x0002) +(defconstant +lbs-noredraw+ #x0004) +(defconstant +lbs-multiplesel+ #x0008) +(defconstant +lbs-ownerdrawfixed+ #x0010) +(defconstant +lbs-ownerdrawvariable+ #x0020) +(defconstant +lbs-hasstrings+ #x0040) +(defconstant +lbs-usetabstops+ #x0080) +(defconstant +lbs-nointegralheight+ #x0100) +(defconstant +lbs-multicolumn+ #x0200) +(defconstant +lbs-wantkeyboardinput+ #x0400) +(defconstant +lbs-extendedsel+ #x0800) +(defconstant +lbs-disablenoscroll+ #x1000) +(defconstant +lbs-nodata+ #x2000) +(defconstant +lbs-nosel+ #x4000) +(defconstant +lbs-combobox+ #x8000) + (defconstant +lf-facesize+ 32) (defconstant +lf-fullfacesize+ 64) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Aug 29 15:28:42 2006 @@ -37,6 +37,13 @@ ;;; convenience functions ;;; +(defun indexed-sort (sequence predicate key) + (let* ((tmp1 (loop for item in sequence + collect (list (funcall key item) item))) + (tmp2 (sort tmp1 predicate :key #'first))) + (loop for item in tmp2 + collect (second item)))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Tue Aug 29 15:28:42 2006 @@ -95,3 +95,7 @@ (if (null pos) (return-from item-index 0)) 0)) + +(defmethod update-from-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) Added: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 15:28:42 2006 @@ -0,0 +1,102 @@ +;;;; +;;;; list-box.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 ((self list-box) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ + gfs::+ws-vscroll+ gfs::+ws-border+)) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary list-box styles + ;; + (:extend-select (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) + (setf std-flags (logior std-flags + gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+))) + + (:multiple (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) + (setf std-flags (logior std-flags gfs::+lbs-multiplesel+))) + + (:no-select (setf std-flags (logand std-flags + (lognot (logior gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+)))) + (setf std-flags (logior std-flags gfs::+lbs-nosel+))) + + ;; styles that can be combined + ;; + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) + + (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::*listbox-classname* + "" + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self) + (update-from-items self)) + +(defmethod (setf items) :after (new-items (self list-box)) + (declare (ignore new-items)) + (update-from-items self)) + +(defmethod update-from-items ((self list-box)) + (let ((collator (collator-of self)) + (items (items-of self)) + (hwnd (gfs:handle self))) + (when collator + (setf items (gfs::indexed-sort items collator (lambda (it) (data-of it))) + (items-of self) items)) + (enable-redraw self nil) + (unwind-protect + (progn + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (loop for item in items + do (append-item self item ???))) + (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Aug 29 15:28:42 2006 @@ -159,7 +159,11 @@ (:documentation "This class represents the standard font dialog.")) (defclass item-manager () - ((items + ((collator + :accessor collator-of + :initarg :collator + :initform nil) + (items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Aug 29 15:28:42 2006 @@ -203,12 +203,22 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enabled-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod enabled-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enabled-p ((w widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod enable-redraw :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod enable-redraw ((self widget) flag) + (gfs::send-message (gfs:handle self) gfs::+wm-setredraw+ (if flag 1 0) 0) + (if flag + (redraw self))) + +(defmethod enabled-p ((self widget)) + (not (zerop (gfs::is-window-enabled (gfs:handle self))))) (defmethod image :before ((self widget)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r241 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 18:52:53 2006 New Revision: 241 Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: item-manager now has slots for functions to obtain text and image from item data, revised append-item accordingly Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 18:52:53 2006 @@ -10,25 +10,27 @@ @anchor{ancestor-p} @deffn GenericFunction ancestor-p ancestor descendant => boolean -Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. +Returns T if @var{ancestor} is the parent of @var{descendant}; @sc{nil} +otherwise. @end deffn @anchor{append-item} -@deffn GenericFunction append-item self text image dispatcher &optional disabled checked -Adds the new item with the specified @code{text}, @code{image}, and -@ref{event-dispatcher} to the object, and returns the newly-created item. -The optional @code{checked} and @code{disabled} arguments can be used -to set the item's initial state. -@end deffn - -@deffn GenericFunction append-separator self -Adds a separator item to the object, and returns the newly-created -item. -@end deffn - -@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked -Adds a submenu anchored to a parent menu and returns the corresponding -menu item. The optional @code{checked} and @code{disabled} arguments can +@deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} +Adds a new item representing @var{thing} to @var{self}, where the +class of @var{self} must derive from @ref{item-manager}. The +newly-created item is returned. The @var{dispatcher} parameter must +be an instance of @ref{event-dispatcher} or a subclass thereof. The +optional @var{checked} and @var{disabled} arguments can be used to set +the item's initial state. +@end deffn + +@deffn GenericFunction append-separator self => @ref{item} +Adds a separator item to @var{self}, and returns the newly-created item. +@end deffn + +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +Adds @var{submenu} anchored to @var{self} and returns the corresponding +@ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can be used to set the menu item's initial state. @end deffn Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 18:52:53 2006 @@ -60,24 +60,35 @@ @end deftp @anchor{item} -@deftp Class item item-id +@deftp Class item data item-id This is the base class for all non-windowed user interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var +@item data +A reference to the application-defined object to be wrapped +by the item. @item item-id An identifier for the item managed internally by Graphic-Forms. @end table @end deftp @anchor{item-manager} -@deftp Class item-manager items +@deftp Class item-manager image-provider items text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. - @table @var +@item image-provider +This slot holds a function accepting one argument and returning an +instance of @ref{image}. The default implementation simply +returns @sc{nil}. @item items An @sc{adjustable} @sc{vector} containing @ref{item}s representing sub-elements. +@item text-provider +This slot holds a function accepting one argument and returning a +@sc{string}. The default implementation checks whether the argument +is already a @sc{string}, and if so just returns it; otherwise it +calls @sc{format}. @end table @end deftp @@ -356,10 +367,8 @@ @end deffn @deffn Initarg :initial-items This initarg accepts a list of objects for initially populating the -contents of the list-box. @sc{print-object} will be called for -each object to produce the corresponding item's display string. -The list-box will hold references to the supplied objects. See -also @ref{append-item}. +contents of the list-box. The list-box will hold references to the +supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @deffn Initarg :style Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Aug 28 18:52:53 2006 @@ -177,7 +177,7 @@ (gfw:mapchildren *layout-tester-win* (lambda (parent child) (declare (ignore parent)) - (let ((it (gfw::append-item menu (gfw:text child) nil nil))) + (let ((it (gfw::append-item menu (gfw:text child) 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)) @@ -378,9 +378,9 @@ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) (let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*)))) - (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize)) + (setf it (gfw:append-item menu "Normalize" #'set-flow-layout-normalize)) (gfw:check it (find :normalize style)) - (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (setf it (gfw:append-item menu "Wrap" #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) (defun exit-layout-callback (disp item) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 18:52:53 2006 @@ -33,8 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) - (declare (ignore text image disp checked disabled)) +;;; +;;; helper functions +;;; + +(defun call-text-provider (manager thing) + (let ((func (text-provider-of manager)) + (*print-readably* nil)) + (cond + ((stringp thing) + thing) + ((null func) + (format nil "~a" thing)) + (t + (funcall func thing))))) + +;;; +;;; methods +;;; + +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) + (declare (ignore thing disp checked disabled)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Aug 28 18:52:53 2006 @@ -32,7 +32,7 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) - + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Aug 28 18:52:53 2006 @@ -166,15 +166,15 @@ (error 'gfs:win32-error :detail "set-menu-item-info failed")) (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) -(defun create-menuitem-with-callback (hmenu disp) +(defun create-menuitem-with-callback (hmenu thing disp) (let ((item nil)) (cond ((null disp) - (setf item (make-instance 'menu-item :handle hmenu))) + (setf item (make-instance 'menu-item :data thing :handle hmenu))) ((functionp disp) - (setf item (make-instance 'menu-item :handle hmenu :callback disp))) + (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) + (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Aug 28 18:52:53 2006 @@ -167,6 +167,8 @@ ;;; code generation ;;; +(defstruct menu-item-data text image) + (defun generate-menusystem-code (sexp generator-sym) (let ((code nil)) (mapcar #'(lambda (var) @@ -177,19 +179,25 @@ (defclass win32-menu-generator (base-menu-generator) ()) (defmethod initialize-instance :after ((gen win32-menu-generator) &key) - (let ((m (make-instance 'menu :handle (gfs::create-menu)))) + (let ((m (make-instance 'menu :handle (gfs::create-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (put-widget (thread-context) m) (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) - (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked)) + (append-item (first (menu-stack-of gen)) + (make-menu-item-data :text label :image image) + dispatcher disabled checked)) (defmethod define-separator ((gen win32-menu-generator)) (let ((owner (first (menu-stack-of gen)))) (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))) + (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled) (push submenu (menu-stack-of gen)))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Aug 28 18:52:53 2006 @@ -90,12 +90,12 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) text image disp &optional disabled checked) - (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items +(defmethod append-item ((owner menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) (hmenu (gfs:handle owner)) - (item (create-menuitem-with-callback hmenu disp))) + (item (create-menuitem-with-callback hmenu thing disp)) + (text (call-text-provider owner thing))) (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (setf (item-id item) id) (put-menuitem tc item) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 18:52:53 2006 @@ -80,6 +80,10 @@ :accessor item-id :initarg :item-id :initform 0) + (data + :accessor data-of + :initarg :data + :initform nil) (callback-event-name :accessor callback-event-name-of :initform 'event-select @@ -158,7 +162,15 @@ ((items :accessor items ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t))) + :initform (make-array 7 :fill-pointer 0 :adjustable t)) + (text-provider + :accessor text-provider-of + :initarg :text-provider + :initform nil) + (image-provider + :accessor image-provider-of + :initarg :image-provider + :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) (defclass list-box (widget item-manager) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Aug 28 18:52:53 2006 @@ -45,8 +45,8 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self text image dispatcher &optional checked disabled) - (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) +(defgeneric append-item (self thing dispatcher &optional checked disabled) + (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self) (:documentation "Add a separator item to the object, and returns the newly-created item."))

1 0

[graphic-forms-cvs] r240 - trunk/docs/manual
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 16:33:21 2006 New Revision: 240 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo Log: refined controls section of manual, added more doc for list-box Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Aug 28 16:33:21 2006 @@ -89,6 +89,21 @@ The @ref{point} location of the mouse cursor. @end macro +@macro control-callback-initarg{classname,callbackname} +@deffn Initarg :callback +The function supplied via this initarg will be used as +the implementation of @sc{@ref{\callbackname\}} in an +@ref{event-dispatcher} configured for the \classname\. +See also @var{callback-event-name}. +@end deffn +@end macro + +@macro control-parent-initarg{classname} +@deffn Initarg :parent +This initarg specifies the @ref{parent} of the \classname\. +@end deffn +@end macro + @macro begin-control-subclass{classname,descr,callbackname} @anchor{\classname\} @deftp Class \classname\ callback-event-name Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 16:33:21 2006 @@ -8,10 +8,12 @@ @node Widget functions @subsection Widget functions -@deffn GenericFunction ancestor-p ancestor descendant -Returns T if ancestor is an ancestor of descendant; nil otherwise. +@anchor{ancestor-p} +@deffn GenericFunction ancestor-p ancestor descendant => boolean +Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. @end deffn +@anchor{append-item} @deffn GenericFunction append-item self text image dispatcher &optional disabled checked Adds the new item with the specified @code{text}, @code{image}, and @ref{event-dispatcher} to the object, and returns the newly-created item. Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 16:33:21 2006 @@ -61,13 +61,13 @@ @anchor{item} @deftp Class item item-id -The @code{item} class is the base class for all non-windowed user -interface objects serving as subcomponents of a -@ref{item-manager} object. It derives from @ref{event-source}. -@deffn Initarg :item-id -@end deffn -@deffn Accessor item-id -@end deffn +This is the base class for all non-windowed user +interface objects serving as subcomponents of an +@ref{item-manager}. It derives from @ref{event-source}. +@table @var +@item item-id +An identifier for the item managed internally by Graphic-Forms. +@end table @end deftp @anchor{item-manager} @@ -104,7 +104,7 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{item-manager}. +derives from @ref{widget} and @ref{item-manager}. @end deftp @anchor{menu-item} @@ -146,17 +146,14 @@ @subsection Controls @begin-control-subclass{button, -This @ref{control} class represents selectable controls that generate +This @ref{control} subclass represents selectable controls that generate an event when clicked., event-select} -@deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-select} in an -@ref{event-dispatcher} configured for the @code{button}. -@end deffn +@control-callback-initarg{button,event-select} @deffn Initarg :image -Supplies an image to be used as the @code{button}'s label. +Supplies an image to be used as the button's label. @end deffn +@control-parent-initarg{button} @deffn Initarg :style @table @code @item :cancel-button @@ -165,26 +162,26 @@ action should be interpreted as the user discarding the content of the dialog. @item :check-box -This style specifies a @code{button} having a small box, which may -contain a check mark depending on the @code{button}'s selection state, +This style specifies a button having a small box, which may +contain a check mark depending on the button's selection state, adjacent to a text label. @item :default-button Placing a @code{:default-button} in a dialog enables the @sc{return} key @ref{accelerator} for dismissing the dialog. This action should be interpreted as the user accepting the content of the dialog. Also, the -@code{button} is rendered with an extra thick border. +button is rendered with an extra thick border. @item :push-button This style specifies a traditional push button control. No special keyboard accelerators are enabled. @item :radio-button -This style specifies a @code{button} having a small circle, which may -be filled or unfilled depending on the @code{button}'s selection -state, adjacent to a text label. Radio @code{button}s are typically +This style specifies a button having a small circle, which may +be filled or unfilled depending on the button's selection +state, adjacent to a text label. Radio buttons are typically used in groups and are managed such that only one member of the group is enabled at a time. @item :toggle-button This style specifies a control that when unselected looks like a push -@code{button}. But when in the selected state, the @code{button} +button. But when in the selected state, the button maintains a sunken look. It is similar in function to a @code{:check-box}. @item :tri-state @@ -194,7 +191,7 @@ @end table @end deffn @deffn Initarg :text -Supplies the text for the @code{button} label. +Supplies the text for the button label. @end deffn @end-control-subclass @@ -202,67 +199,65 @@ @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @ref{widget}.@*@* -@strong{Note:} application code should not manipulate @code{control} slots -directly, unless defining a new @code{control} type as an extension to +@strong{Note:} application code should not manipulate control slots +directly, unless defining a new control type as an extension to Graphic-Forms. @table @var @item brush-color -If set, this @ref{color} object is used as the @code{control}'s background color -when the @code{control} needs to be redrawn. +If set, this @ref{color} object is used as the control's background color +when the control needs to be redrawn. @item brush-handle This is a native handle for a Win32 @sc{brush} that is used when customizing -the @code{control}'s background color. +the control's background color. @item font -This is a @ref{font} object for customizing the text of a @code{control}. +This is a @ref{font} object for customizing the text of a control. @item pixel-point This is a @ref{point} object specifying a pixel in an @ref{image} -associated with a @code{control}, for the purpose of determining what +associated with a control, for the purpose of determining what color to use for transparency. @item maximum-size This is a @ref{size} object that places a maximum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item minimum-size This is a @ref{size} object that places a minimum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item text-color -If set, this color object is used as the @code{control}'s foreground text -color when the @code{control} needs to be redrawn. +If set, this color object is used as the control's foreground text +color when the control needs to be redrawn. @end table @deffn Initarg :callback -This initarg associates a @sc{function} with an @ref{event-dispatcher} +This initarg associates a function with an @ref{event-dispatcher} subclass that is generated behind the scenes and then instantiated to -serve as the @code{control}'s event dispatcher. Each @code{control} +serve as the control's event dispatcher. Each control subclass specifies the particular event function (e.g., @ref{event-select}) that this callback will implement; see the documentation for specific -@code{control} subclasses for more information on this initarg. +control subclasses for more information on this initarg. @end deffn +@control-parent-initarg{control} @end deftp @begin-control-subclass{edit, This subclass of @ref{control} represents a rectangular area that permits the user to enter and edit text. The @ref{event-focus-gain} -and @ref{event-focus-loss} methods of each @code{edit control}'s +and @ref{event-focus-loss} methods of each edit control's @ref{event-dispatcher} are invoked when focus is given or taken away. The @ref{event-modify} method is invoked when the user edits content., event-modify} -@deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-modify} in an -@ref{event-dispatcher} configured for the @code{edit control}. -@end deffn +@control-callback-initarg{edit,event-modify} +@control-parent-initarg{edit} @deffn Initarg :style @table @code @item :auto-hscroll -Specifies that the @code{edit control} will scroll text content to the +Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end -of the line. For single-line @code{edit control}s, this style is set +of the line. For single-line edit controls, this style is set by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @ref{enable-auto-scrolling}. @item :auto-vscroll -Specifies that the @code{edit control} will scroll text up by a page +Specifies that the edit control will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @@ -274,21 +269,21 @@ instead of the one literally typed. The character can be changed via the @ref{echo-character} @sc{setf} method. @item :multi-line -By default, @code{edit control}s are single-line text fields. By specifying +By default, edit controls are single-line text fields. By specifying @code{:multi-line}, multiple lines of text can be supplied. When the -@code{edit control} is in a @ref{dialog}, the @sc{enter} key will invoke +edit control is in a @ref{dialog}, the @sc{enter} key will invoke the default @ref{button}'s @ref{event-dispatcher}, unless @code{:want-return} is also specified. If @code{:auto-hscroll} is not specified, then text will be automatically word-wrapped. @item :no-border -By default, an @code{edit control} is rendered with a border; this style +By default, an edit control is rendered with a border; this style keyword disables that feature. @item :no-hide-selection This specifies that any selection remain rendered even when the -@code{edit control} loses input focus. By default, the selection +edit control loses input focus. By default, the selection is hidden when focus is lost. @item :read-only -Specifies that the @code{edit control}'s contents cannot be modified by +Specifies that the edit control's contents cannot be modified by the user. @item :vertical-scrollbar Specifies that a vertical scrollbar should be displayed. @@ -301,13 +296,14 @@ @end table @end deffn @deffn Initarg :text -Supplies the initial text for the @code{edit control}. +Supplies the initial text for the edit control. @end deffn @end-control-subclass @begin-control-subclass-no-callback{label, This @ref{control} subclass represents non-selectable controls that display a string\, image\, or etched line.} +@control-parent-initarg{label} @deffn Initarg :image Supply an @ref{image} object as the value of this initarg to configure the label to display the image rather than text. @@ -347,8 +343,50 @@ @end-control-subclass @begin-control-subclass{list-box, -This @ref{control} class represents a list of selectable items., +This @ref{control} subclass represents a list of selectable items; it +also inherits @ref{item-manager}. The list is always visible\, unlike +a combo-box., event-select} +@control-callback-initarg{list-box,event-select} +@deffn Initarg :collator +This initarg accepts a predicate function of two arguments +returning a @sc{boolean}, for the purpose of ordering the list-box +items. The arguments passed are the application-supplied data objects +used to populate the list-box. +@end deffn +@deffn Initarg :initial-items +This initarg accepts a list of objects for initially populating the +contents of the list-box. @sc{print-object} will be called for +each object to produce the corresponding item's display string. +The list-box will hold references to the supplied objects. See +also @ref{append-item}. +@end deffn +@control-parent-initarg{list-box} +@deffn Initarg :style +@table @code +@item :extend-select +This style keyword causes the list-box to allow multiple items to +be selected by use of the @sc{shift} key and the mouse or special +keys. +@item :multiple-select +This style keyword enables individual toggling of multiple item +selections within the list-box. Without this style, the list-box will +only allow a single selection. +@item :no-select +This style keyword means that the list-box will display items but +not allow any selections. +@item :tab-stops +This style keyword configures the list-box to to expand tab characters +when rendering item strings. +@item :want-keys +This style keyword allows the application to perform special processing +when the list-box has focus and the user presses a key. +@item :want-scrollbar +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden. +@end table +@end deffn @end-control-subclass

1 0

[graphic-forms-cvs] r239 - in trunk: . docs/manual src src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 11:20:02 2006 New Revision: 239 Added: trunk/src/uitoolkit/widgets/item-manager.lisp - copied, changed from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp Removed: trunk/src/uitoolkit/widgets/widget-with-items.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: widget-with-items base class renamed to item-manager and is now a mix-in Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 28 11:20:02 2006 @@ -75,7 +75,7 @@ * Layouts:: Layout manager classes. * Controls:: Control classes. * Windows and dialogs:: Window and dialog classes. -* Miscellaneous types:: Base classes for more specialized kinds of widgets. +* Miscellaneous types:: Assorted base classes and utility classes. * Event functions:: Functions related to event processing. * Layout functions:: Functions related to layout management. * Widget functions:: Functions related to widgets. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Mon Aug 28 11:20:02 2006 @@ -63,6 +63,13 @@ invoked in a context-sensitive manner via the mouse or an @ref{accelerator}.@* +@item mix-in class +@anchor{mix-in class} +@cindex mix-in class +A mix-in class represents a specific abstraction that +complements the role(s) of other class(es) in a class +hierarchy.@* + @item mnemonic @anchor{mnemonic} @cindex mnemonic Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 11:20:02 2006 @@ -63,13 +63,24 @@ @deftp Class item item-id The @code{item} class is the base class for all non-windowed user interface objects serving as subcomponents of a -@ref{widget-with-items} object. It derives from @ref{event-source}. +@ref{item-manager} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @end deffn @end deftp +@anchor{item-manager} +@deftp Class item-manager items +This is is a mix-in class for @ref{widget}s containing sub-elements. + +@table @var +@item items +An @sc{adjustable} @sc{vector} containing @ref{item}s representing +sub-elements. +@end table +@end deftp + @anchor{layout-managed} @deftp Class layout-managed layout layout-p Instances of this class employ a @ref{layout-manager} to maintain @@ -93,9 +104,10 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{widget-with-items}. +derives from @ref{item-manager}. @end deftp +@anchor{menu-item} @deftp Class menu-item A subclass of @ref{item} representing a @ref{menu} item. @end deftp @@ -129,14 +141,6 @@ behavior of the widget; style keywords are widget-specific. @end deftp -@anchor{widget-with-items} -@deftp Class widget-with-items items -The widget-with-items class is the base class for objects composed of -sub-items. It derives from @ref{widget}. The @code{items} slot is an -@sc{adjustable} @sc{vector} containing @ref{item} objects, -representing sub-elements of the widget. -@end deftp - @node Controls @subsection Controls Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 28 11:20:02 2006 @@ -131,7 +131,7 @@ (:file "edit") (:file "label") (:file "button") - (:file "widget-with-items") + (:file "item-manager") (:file "menu") (:file "menu-item") (:file "menu-language") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 28 11:20:02 2006 @@ -256,6 +256,7 @@ #:flow-layout #:heap-layout #:item + #:item-manager #:layout-managed #:layout-manager #:menu @@ -265,7 +266,6 @@ #:timer #:top-level #:widget - #:widget-with-items #:window ;; constants Copied: trunk/src/uitoolkit/widgets/item-manager.lisp (from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 11:20:02 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; widget-with-items.lisp +;;;; item-manager.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -33,23 +33,23 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) +(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) (declare (ignore text image disp checked disabled)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-all ((self widget-with-items)) +(defmethod delete-all ((self item-manager)) (let ((items (items self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) -(defmethod delete-item :before ((self widget-with-items) index) +(defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item ((self widget-with-items) index) +(defmethod delete-item ((self item-manager) index) (let* ((items (items self)) (it (elt items index))) (setf (items self) (remove it items :test #'items-equal-p)) @@ -57,21 +57,21 @@ (error 'gfs:disposed-error)) (gfs:dispose it))) -(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) -(defmethod item-index :before ((self widget-with-items) (it item)) +(defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod item-index ((self widget-with-items) (it item)) +(defmethod item-index ((self item-manager) (it item)) (let ((pos (position it (items self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 11:20:02 2006 @@ -154,21 +154,21 @@ (defclass font-dialog (widget) () (:documentation "This class represents the standard font dialog.")) -(defclass widget-with-items (widget) +(defclass item-manager () ((items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))) - (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) + (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget-with-items) +(defclass list-box (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select :allocation :class)) ; shadowing same slot from event-source (:documentation "The list-box class represents the standard listbox control.")) -(defclass menu (widget-with-items) +(defclass menu (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-activate

1 0