[graphic-forms-cvs] r36 - in trunk/src: tests/uitoolkit uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sun Mar 12 21:06:21 2006
New Revision: 36

Modified:
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/flow-layout.lisp
   trunk/src/uitoolkit/widgets/layout.lisp
   trunk/src/uitoolkit/widgets/menu-language.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
enhance append-submenu so it can take callback or dispatcher

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Mar 12 21:06:21 2006
@@ -157,6 +157,12 @@
       (gfw:show victim (not (gfw:visible-p victim)))
       (gfw:layout *layout-tester-win*))))
 
+(defun check-flow-orient-item (disp menu time)
+  (declare (ignore disp time))
+  (let ((layout (gfw:layout-manager *layout-tester-win*)))
+    (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout)))
+    (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout)))))
+
 (defun set-flow-horizontal (disp item time rect)
   (declare (ignorable disp item time rect))
   (let ((layout (gfw:layout-manager *layout-tester-win*)))
@@ -191,9 +197,9 @@
                                           :callback #'set-flow-vertical))))
         (spacing-menu (gfw:defmenusystem ((:item "Decrease")
                                           (:item "Increase")))))
-    (gfw:append-submenu menu "Margin" margin-menu)
-    (gfw:append-submenu menu "Orientation" orient-menu)
-    (gfw:append-submenu menu "Spacing" spacing-menu)
+    (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)
     (setf it (gfw:append-item menu "Fill" nil nil))
     (gfw:check it t)
     (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))

Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp	Sun Mar 12 21:06:21 2006
@@ -87,7 +87,7 @@
                                                 :size size
                                                 :location pnt))
                        entries))))
-  (reverse entries)))
+  (nreverse entries)))
 
 ;;;
 ;;; methods

Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layout.lisp	Sun Mar 12 21:06:21 2006
@@ -45,7 +45,6 @@
         (hdwp nil))
     (when (and (layout-p win) layout)
       (setf kids (compute-layout layout win width-hint height-hint))
-(loop for x in kids do (format t "~a~%" (cdr x)))
       (setf hdwp (gfs::begin-defer-window-pos (length kids)))
       (loop for k in kids
             do (let* ((rect (cdr k))

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Sun Mar 12 21:06:21 2006
@@ -211,9 +211,9 @@
     (vector-push-extend it (items owner))))
 
 (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
-  (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
+  (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))
          (parent (first (menu-stack-of gen)))
-         (item (append-submenu parent label submenu)))
+         (item (append-submenu parent label submenu dispatcher)))
     (push submenu (menu-stack-of gen))
     (enable item (not disabled))))
 

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Sun Mar 12 21:06:21 2006
@@ -141,7 +141,7 @@
     (vector-push-extend item (items owner))
     item))
 
-(defmethod append-submenu ((parent menu) text (submenu menu))
+(defmethod append-submenu ((parent menu) text (submenu menu) disp)
   (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu))
     (error 'gfi:disposed-error))
   (let* ((tc (thread-context))
@@ -154,6 +154,16 @@
     (put-menuitem tc item)
     (vector-push-extend item (items parent))
     (put-widget tc submenu)
+    (cond
+      ((null disp))
+      ((functionp disp)
+         (let ((class (define-dispatcher `((event-activate . ,disp)))))
+           (setf (dispatcher submenu) (make-instance (class-name class)))))
+      ((typep disp 'gfw:event-dispatcher)
+         (setf (dispatcher submenu) disp))
+      (t
+         (error 'gfs:toolkit-error
+           :detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
     item))
 
 (defun menu-cleanup-callback (menu item)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Sun Mar 12 21:06:21 2006
@@ -48,7 +48,7 @@
 (defgeneric append-item (object text image dispatcher)
   (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
 
-(defgeneric append-submenu (object text submenu)
+(defgeneric append-submenu (object text submenu dispatcher)
   (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
 
 (defgeneric background-color (object)