[graphic-forms-cvs] r40 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Mar 14 06:20:03 UTC 2006
Author: junrue
Date: Tue Mar 14 01:20:02 2006
New Revision: 40
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/layout-classes.lisp
trunk/src/uitoolkit/widgets/menu-item.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented widget and menu item enabling/disabling; implemented flow layout spacing
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Mar 14 01:20:02 2006
@@ -448,6 +448,7 @@
#:show-selection
#:shutdown
#:size
+ #:spacing-of
#:startup
#:step-increment
#:style-of
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 01:20:02 2006
@@ -36,6 +36,7 @@
(defconstant +btn-text-before+ "Push Me")
(defconstant +btn-text-after+ "Again!")
(defconstant +label-text+ "Test Label")
+(defconstant +spacing-delta+ 3)
(defvar *widget-counter* 0)
@@ -157,7 +158,7 @@
(gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
-(defun check-flow-orient-item (disp menu time)
+(defun check-flow-orient-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout)))
@@ -190,6 +191,26 @@
(setf (gfw:style-of layout) (push :wrap style)))
(gfw:layout *layout-tester-win*)))
+(defun enable-flow-spacing-items (disp menu time)
+ (declare (ignore disp time))
+ (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
+ (gfw:enable (gfw:item-at menu 0) (> spacing 0))))
+
+(defun decrease-flow-spacing (disp item time rect)
+ (declare (ignore disp item time rect))
+ (let* ((layout (gfw:layout-of *layout-tester-win*))
+ (spacing (gfw:spacing-of layout)))
+ (unless (zerop spacing)
+ (decf spacing +spacing-delta+)
+ (setf (gfw:spacing-of layout) spacing)
+ (gfw:layout *layout-tester-win*))))
+
+(defun increase-flow-spacing (disp item time rect)
+ (declare (ignore disp item time rect))
+ (let ((layout (gfw:layout-of *layout-tester-win*)))
+ (incf (gfw:spacing-of layout) +spacing-delta+)
+ (gfw:layout *layout-tester-win*)))
+
(defun flow-mod-callback (disp menu time)
(declare (ignore disp time))
(gfw:clear-all menu)
@@ -210,11 +231,13 @@
:callback #'set-flow-horizontal)
(:item "Vertical"
:callback #'set-flow-vertical))))
- (spacing-menu (gfw:defmenusystem ((:item "Decrease")
- (:item "Increase")))))
+ (spacing-menu (gfw:defmenusystem ((:item "Decrease"
+ :callback #'decrease-flow-spacing)
+ (:item "Increase"
+ :callback #'increase-flow-spacing)))))
(gfw:append-submenu menu "Margin" margin-menu nil)
- (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item)
- (gfw:append-submenu menu "Spacing" spacing-menu nil)
+ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items)
+ (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items)
(setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
(gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*))))))
@@ -233,7 +256,8 @@
(vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher
:check-test-fn #'gfw:visible-p)))
(setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
- :layout (make-instance 'gfw:flow-layout)))
+ :layout (make-instance 'gfw:flow-layout
+ :spacing +spacing-delta+)))
(gfw:realize *layout-tester-win* nil :style-workspace)
(setf menubar (gfw:defmenusystem ((:item "&File"
:submenu ((:item "E&xit"
Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Tue Mar 14 01:20:02 2006
@@ -53,6 +53,8 @@
(define-test flow-layout-test1
;; orient: horizontal
;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: unrestricted width and height
;; kids: uniform
;;
@@ -67,6 +69,8 @@
(define-test flow-layout-test2
;; orient: vertical
;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: unrestricted width and height
;; kids: uniform
;;
@@ -81,6 +85,8 @@
(define-test flow-layout-test3
;; orient: horizontal
;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: restricted width, unrestricted height
;; kids: uniform
;;
@@ -92,6 +98,8 @@
(define-test flow-layout-test4
;; orient: vertical
;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: unrestricted width, restricted height
;; kids: uniform
;;
@@ -103,6 +111,8 @@
(define-test flow-layout-test5
;; orient: horizontal
;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: restricted width and height
;; kids: uniform
;;
@@ -114,6 +124,8 @@
(define-test flow-layout-test6
;; orient: vertical
;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
;; container: restricted width and height
;; kids: uniform
;;
@@ -121,3 +133,61 @@
(data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25))
(expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
(validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test7
+ ;; orient: horizontal
+ ;; wrap: disabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal)))
+ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
+ (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10))))
+ (assert-equal 68 (gfi:size-width size))
+ (assert-equal 10 (gfi:size-height size))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test8
+ ;; orient: vertical
+ ;; wrap: disabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical)))
+ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
+ (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10))))
+ (assert-equal 20 (gfi:size-width size))
+ (assert-equal 38 (gfi:size-height size))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test9
+ ;; orient: horizontal
+ ;; wrap: enabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18))
+ (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10))))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test10
+ ;; orient: vertical
+ ;; wrap: enabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25))
+ (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10))))
+ (validate-layout-rects data expected-rects)))
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 14 01:20:02 2006
@@ -128,6 +128,19 @@
(hwnd HANDLE))
(defcfun
+ ("EnableMenuItem" enable-menu-item)
+ BOOL
+ (hmenu HANDLE)
+ (id UINT)
+ (flag UINT))
+
+(defcfun
+ ("EnableWindow" enable-window)
+ BOOL
+ (hwnd HANDLE)
+ (enable BOOL))
+
+(defcfun
("EndDeferWindowPos" end-defer-window-pos)
BOOL
(posinfo HANDLE))
@@ -303,6 +316,11 @@
(erase BOOL))
(defcfun
+ ("IsWindowEnabled" is-window-enabled)
+ BOOL
+ (hwnd HANDLE))
+
+(defcfun
("IsWindowVisible" is-window-visible)
BOOL
(hwnd HANDLE))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Tue Mar 14 01:20:02 2006
@@ -55,6 +55,10 @@
(incf total (gfi:size-width size))
(if (< max (gfi:size-height size))
(setf max (gfi:size-height size))))))))
+ (if (< (spacing-of layout) 0)
+ (error 'gfs:toolkit-error :detail "layout spacing must be non-negative"))
+ (unless (null kids)
+ (incf total (* (spacing-of layout) (1- (length kids)))))
(if vert-orient
(gfi:make-size :width max :height total)
(gfi:make-size :width total :height max))))
@@ -65,9 +69,12 @@
(max-size -1)
(next-coord 0)
(wrap-coord 0)
+ (spacing (spacing-of layout))
(style (style-of layout))
(vert-orient (find :vertical style))
(wrap (find :wrap style)))
+ (if (< spacing 0)
+ (error 'gfs:toolkit-error :detail "layout spacing must be non-negative"))
(loop for kid in kids
do (let ((size (preferred-size kid -1 -1))
(pnt (gfi:make-point)))
@@ -80,13 +87,13 @@
(push (reverse curr-flow) flows)
(setf curr-flow nil)
(setf next-coord 0)
- (incf wrap-coord max-size)
+ (incf wrap-coord (+ max-size spacing))
(setf max-size -1))
(setf (gfi:point-x pnt) wrap-coord)
(setf (gfi:point-y pnt) next-coord)
(if (< max-size (gfi:size-width size))
(setf max-size (gfi:size-width size)))
- (incf next-coord (gfi:size-height size)))
+ (incf next-coord (+ (gfi:size-height size) spacing)))
(progn
(when (and wrap
(>= width-hint 0)
@@ -94,13 +101,13 @@
(push (reverse curr-flow) flows)
(setf curr-flow nil)
(setf next-coord 0)
- (incf wrap-coord max-size)
+ (incf wrap-coord (+ max-size spacing))
(setf max-size -1))
(setf (gfi:point-x pnt) next-coord)
(setf (gfi:point-y pnt) wrap-coord)
(if (< max-size (gfi:size-height size))
(setf max-size (gfi:size-height size)))
- (incf next-coord (gfi:size-width size))))
+ (incf next-coord (+ (gfi:size-width size) spacing))))
(push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow))))
(unless (null curr-flow)
(push (reverse curr-flow) flows))
Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-classes.lisp Tue Mar 14 01:20:02 2006
@@ -40,5 +40,9 @@
:initform nil))
(:documentation "Subclasses implement layout strategies on behalf of window objects."))
-(defclass flow-layout (layout-manager) ()
+(defclass flow-layout (layout-manager)
+ ((spacing
+ :accessor spacing-of
+ :initarg :spacing
+ :initform 0))
(:documentation "Window children are arranged in a row or column."))
Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Mar 14 01:20:02 2006
@@ -37,6 +37,30 @@
;;; helper functions
;;;
+(defun get-menuitem-state (hmenu mid)
+ (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+ gfs::state gfs::id gfs::hsubmenu
+ gfs::hbmpchecked gfs::hbmpunchecked
+ gfs::idata gfs::tdata gfs::cch
+ gfs::hbmpitem)
+ mii-ptr gfs::menuiteminfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+ (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+))
+ (setf gfs::type 0)
+ (setf gfs::state 0)
+ (setf gfs::id mid)
+ (setf gfs::hsubmenu (cffi:null-pointer))
+ (setf gfs::hbmpchecked (cffi:null-pointer))
+ (setf gfs::hbmpunchecked (cffi:null-pointer))
+ (setf gfs::idata 0)
+ (setf gfs::tdata (cffi:null-pointer))
+ (setf gfs::cch 0)
+ (setf gfs::hbmpitem (cffi:null-pointer))
+ (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
+ (error 'gfs:win32-error :detail "get-menu-item-info failed"))
+ gfs::state)))
+
(defun get-menuitem-text (hmenu mid)
(cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
(cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
@@ -58,7 +82,7 @@
(setf gfs::cch 0)
(setf gfs::hbmpitem (cffi:null-pointer))
(if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
- (error 'gfs::win32-error :detail "get-menu-item-info failed"))
+ (error 'gfs:win32-error :detail "get-menu-item-info failed"))
(incf gfs::cch)
(let ((str-ptr (cffi:foreign-alloc :char :count gfs::cch))
(result ""))
@@ -66,7 +90,7 @@
(progn
(setf gfs::tdata str-ptr)
(if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
- (error 'gfs::win32-error :detail "get-menu-item-info failed"))
+ (error 'gfs:win32-error :detail "get-menu-item-info failed"))
(setf result (cffi:foreign-string-to-lisp str-ptr))
(cffi:foreign-free str-ptr)))
result))))
@@ -184,9 +208,17 @@
(setf (item-id it) 0)
(setf (slot-value it 'gfi:handle) nil)))
-(defmethod enable ((item menu-item) flag)
- ;; FIXME: need to implement
-)
+(defmethod enable ((it menu-item) flag)
+ (let ((bits 0))
+ (if flag
+ (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+))
+ (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+)))
+ (gfs::enable-menu-item (gfi:handle it) (item-id it) bits)))
+
+(defmethod enabled-p ((it menu-item))
+ (= (logand (get-menuitem-state (gfi:handle it) (item-id it))
+ gfs::+mfs-enabled+)
+ gfs::+mfs-enabled+))
(defmethod item-owner ((it menu-item))
(let ((hmenu (gfi:handle it)))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 14 01:20:02 2006
@@ -105,6 +105,21 @@
(error 'gfs:win32-error :detail "destroy-window failed"))))
(setf (slot-value w 'gfi:handle) nil))
+(defmethod enable :before ((w widget) flag)
+ (declare (ignore flag))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod enable ((w widget) flag)
+ (gfs::enable-window (gfi:handle w) (if (null flag) 0 1)))
+
+(defmethod enabled-p :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod enabled-p ((w widget))
+ (not (zerop (gfs::is-window-enabled (gfi:handle w)))))
+
(defmethod location :before ((w widget))
(if (gfi:disposed-p w)
(error 'gfi:disposed-error)))
More information about the Graphic-forms-cvs
mailing list