[graphic-forms-cvs] r247 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Sep 5 04:26:39 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list