[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