[graphic-forms-cvs] r252 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sat Sep 9 03:02:06 UTC 2006
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
- at deffn GenericFunction delete-item-span self @ref{span}
-Removes the items from @var{self} whose zero-based indices lie within
-the specified @var{span}.
- at 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
+ at deffn GenericFunction delete-span self @ref{span}
+Removes the content from @var{self} whose zero-based indices lie within
+the specified @var{span}.
+ at 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))
More information about the Graphic-forms-cvs
mailing list