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))