September 2006 - graphic-forms-cvs@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