Author: junrue Date: Fri Sep 8 23:02:05 2006 New Revision: 252

Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp 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/item-manager.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-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: rewrote item dispose / manager delete-item, implemented item-index to replace index-of accessor, added unit-tests

Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 23:02:05 2006 @@ -147,11 +147,6 @@ Removes the @ref{item} at the zero-based @var{index}. @end deffn

-@deffn GenericFunction delete-item-span self @ref{span} -Removes the items from @var{self} whose zero-based indices lie within -the specified @var{span}. -@end deffn - @deffn GenericFunction delete-selection self Removes the subset of items from @var{self} that are in the @samp{selected} state. For a @ref{control} with a text field @@ -159,6 +154,11 @@ selected text. @end deffn

+@deffn GenericFunction delete-span self @ref{span} +Removes the content from @var{self} whose zero-based indices lie within +the specified @var{span}. +@end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system.

Modified: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -69,6 +69,14 @@ :handle *test-hwnd*))))) (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*))))

+(define-test item-manager-positions-test + (let* ((values '(a b c)) + (mgr (make-instance 'mock-item-manager :items values)) + (items (slot-value mgr 'gfw::items))) + (assert-equal 0 (gfw:item-index mgr (elt items 0))) + (assert-equal 1 (gfw:item-index mgr (elt items 1))) + (assert-equal 2 (gfw:item-index mgr (elt items 2))))) + (define-test item-manager-modifications-test (let ((values1 '(a b c)) (values2 '(1 2 3)) @@ -113,7 +121,7 @@ (validate-item 1 (first tmp) nil nil) (assert-equal 3 (length (gfw:items-of mgr2))) (loop for actual in (gfw:items-of mgr2) - for expected in (subseq (append values2 '(4)) 1 4) + for expected in (mapcar (lambda (x) (1+ x)) (subseq values2 0 3)) do (validate-item expected actual nil *test-hwnd*)))

;; delete last item from mgr3 (using dispose) @@ -129,6 +137,6 @@ (assert-equal 3 (length (gfw:items-of mgr1))) (loop for actual in (gfw:items-of mgr1) for expected in (subseq (append values2 '(4)) 1 4) - do (validate-item expected actual nil *test-hwnd*))) + do (validate-item expected actual nil *default-hwnd*)))

(gfw::delete-widget (gfw::thread-context) *default-hwnd*)))))

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 Fri Sep 8 23:02:05 2006 @@ -102,3 +102,88 @@ (assert-equal 3 (length result1)) (assert-equal 3 (length result2)) (validate-array-elements result1 result2)))) + +(define-test remove-element-list-test + (let ((orig '(a b c)) + (remainder nil)) + (multiple-value-bind (tmp victim) (gfs::remove-element orig 1 nil) + (setf remainder tmp) + (assert-equal 2 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c (second tmp)) + (assert-eql 'b victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 1 nil) + (setf remainder tmp) + (assert-equal 1 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 0 nil) + (assert-false tmp) + (assert-eql 'a victim)))) + +(define-test remove-elements-list-test + (let ((orig '(a b c d e f)) + (remainder nil)) + (multiple-value-bind (tmp victims) + (gfs::remove-elements orig (gfs:make-span :start 2 :end 4) nil) + (setf remainder tmp) + (assert-equal 3 (length victims)) + (assert-eql 'c (first victims)) + (assert-eql 'd (second victims)) + (assert-eql 'e (third victims)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'b (second tmp)) + (assert-eql 'f (third tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 1) nil) + (setf remainder tmp) + (assert-equal 2 (length victims)) + (assert-eql 'a (first victims)) + (assert-eql 'b (second victims)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (first tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 0) nil) + (assert-false tmp) + (assert-equal 1 (length victims)) + (assert-eql 'f (first victims))))) + +(define-test remove-element-non-adjustable-array-test + (let ((orig (make-array 3 :initial-contents '(a b c))) + (tmp nil)) + (setf tmp (gfs::remove-element orig 1 (lambda () (make-array 2)))) + (assert-false (array-has-fill-pointer-p tmp)) + (assert-false (adjustable-array-p tmp)) + (assert-equal 2 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'c (elt tmp 1)) + (setf tmp (gfs::remove-element tmp 1 (lambda () (make-array 1)))) + (assert-equal 1 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-false (gfs::remove-element tmp 0 (lambda () (make-array 0)))))) + +(defun reaam-test-make-array () + (make-array 10 :fill-pointer 0 :adjustable t)) + +(define-test remove-elements-adjustable-array-test + (let ((orig (reaam-test-make-array)) + (tmp nil)) + (loop for item in '(a b c d e f) do (vector-push-extend item orig)) + (setf tmp (gfs::remove-elements orig + (gfs:make-span :start 2 :end 4) + #'reaam-test-make-array)) + (assert-true (array-has-fill-pointer-p tmp)) + (assert-true (adjustable-array-p tmp)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'b (elt tmp 1)) + (assert-eql 'f (elt tmp 2)) + (setf tmp (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 1) + #'reaam-test-make-array)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (elt tmp 0)) + (assert-false (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 0) + #'reaam-test-make-array))))

Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Sep 8 23:02:05 2006 @@ -76,6 +76,7 @@

(defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) + (gfw:delete-selection orig-lb) (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb))))))

Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Fri Sep 8 23:02:05 2006 @@ -65,15 +65,51 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result))

-(defun pick-elements (lisp-seq indices &optional count) +(defun pick-elements (sequence indices &optional count) (let ((picks nil)) (if (cffi:pointerp indices) (dotimes (i count) - (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (push (elt sequence (mem-aref indices :unsigned-int i)) picks)) (dotimes (i (length indices)) - (push (elt lisp-seq (elt indices i)) picks))) + (push (elt sequence (elt indices i)) picks))) (reverse picks)))

+(defun add-element (element sequence index) + (cond + ((listp sequence) + (push element sequence)) + ((adjustable-array-p sequence) + (vector-push-extend element sequence)) + (t + (setf (elt sequence index) element))) + sequence) + +(defun remove-element (sequence index creator) + (let ((result nil) + (victim nil)) + (dotimes (i (length sequence)) + (if (= i index) + (setf victim (elt sequence i)) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (if victim (1- i) i))))) + (if (listp result) + (values (reverse result) victim) + (values result victim)))) + +(defun remove-elements (sequence span creator) + (let ((result nil) + (victims nil)) + (dotimes (i (length sequence)) + (if (and (>= i (gfs:span-start span)) (<= i (gfs:span-end span))) + (push (elt sequence i) victims) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (- i (length victims)))))) + (if (listp result) + (values (reverse result) (reverse victims)) + (values result (reverse victims))))) + (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 Fri Sep 8 23:02:05 2006 @@ -61,7 +61,9 @@ (dotimes (i (length new-items)) (let ((item (elt new-items i))) (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) @@ -69,7 +71,9 @@ ((listp new-items) (loop for item in new-items do (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) @@ -98,17 +102,21 @@ (error 'gfs:disposed-error)))

(defmethod delete-item ((self item-manager) index) - (let* ((items (slot-value self 'items)) - (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal)) - (gfs:dispose it))) + (multiple-value-bind (new-items victim) + (gfs::remove-element (slot-value self 'items) index #'make-items-array) + (setf (slot-value self 'items) new-items) + (gfs:dispose victim)))

-(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) +(defmethod delete-selection :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-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 item-manager) (sp gfs:span)) +(defmethod delete-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))))

@@ -127,7 +135,7 @@ (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) - 0)) + pos))

(defmethod items-of ((self item-manager)) (coerce (slot-value self 'items) 'list))

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 8 23:02:05 2006 @@ -116,6 +116,13 @@ (lb-delete-all self) (setf (slot-value self 'items) (make-items-array)))

+(defmethod delete-selection ((self list-box)) + (enable-redraw self nil) + (unwind-protect + (loop for item in (selected-items self) + do (gfs:dispose item)) + (enable-redraw self t))) + (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) @@ -214,6 +221,8 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) + (unless (zerop (lb-item-count hwnd)) + (error 'gfs:toolkit-error :detail "list-box has existing content")) (when sort-func (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) @@ -222,6 +231,5 @@ (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 Fri Sep 8 23:02:05 2006 @@ -70,17 +70,9 @@ ;;;

(defmethod gfs:dispose ((self list-item)) - (let ((index (index-of self)) - (howner (gfs:handle self))) - (if howner - (gfs::send-message howner gfs::+lb-deletestring+ index 0)) - (setf (index-of self) 0)) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) + (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner 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 Fri Sep 8 23:02:05 2006 @@ -90,10 +90,7 @@ :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)) +(defclass list-item (item) () (:documentation "A subclass of item representing an element of a list-box."))

(defclass menu-item (item) ()

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 8 23:02:05 2006 @@ -135,12 +135,12 @@ (defgeneric delete-item (self index) (:documentation "Removes the item at the zero-based index from the object."))

-(defgeneric delete-item-span (self span) - (:documentation "Removes the sequence of items represented by the specified span object.")) - (defgeneric delete-selection (self) (:documentation "Removes items from self that are in the selected state."))

+(defgeneric delete-span (self span) + (:documentation "Removes the sequence of items represented by the specified span object.")) + (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look."))

@@ -213,6 +213,12 @@ (defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object."))

+(defgeneric items-of (self) + (:documentation "Returns a list of item subclasses representing the content of self.")) + +(defgeneric (setf items-of) (items self) + (:documentation "Accepts a list of application data (or list subclasses) to set the content of self.")) + (defgeneric layout (self) (:documentation "Set the size and location of this object's children."))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Sep 8 23:02:05 2006 @@ -165,20 +165,11 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod delete-item :before ((self widget) index) - (declare (ignore index)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod delete-item-span :before ((self widget) span) +(defmethod delete-span :before ((self widget) span) (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod delete-selection :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod gfs:dispose ((self widget)) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self))