X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/21f6214a2c77cbdca88a2e3d5e03bc5afb659ef2..aa9ceddc987ea92cb20b319ff7b1a51bc176b6e8:/examples/testgtk.lisp

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 0ce2632..db0cd4d 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: testgtk.lisp,v 1.6 2004-11-15 19:33:21 espen Exp $
+;; $Id: testgtk.lisp,v 1.12 2004-12-20 00:56:11 espen Exp $
 
 
 ;;; Some of the code in this file are really outdatet, but it is
@@ -55,8 +55,8 @@      (defun ,name ()
 
 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
   `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
-    (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
-    ,@body))
+    ,@body
+    (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
 
 
 
@@ -184,9 +184,9 @@ (defun create-bbox-in-frame (class frame-label spacing width height layout)
    :child (make-instance class
 	   :border-width 5 :layout-style layout :spacing spacing
 ;	   :child-min-width width :child-min-height height
-	   :child (make-instance 'button :label "OK")
-	   :child (make-instance 'button :label "Cancel")
-	   :child (make-instance 'button :label "Help"))))
+	   :child (make-instance 'button :label "gtk-ok" :use-stock t)
+	   :child (make-instance 'button :label "gtk-cancel" :use-stock t)
+	   :child (make-instance 'button :label "gtk-help" :use-stock t))))
 
 (define-toplevel create-button-box (window "Button Boxes")
   (make-instance 'v-box
@@ -238,7 +238,8 @@ (define-simple-dialog create-buttons (dialog "Buttons")
 			      (if (widget-visible-p button+1)
 				  (widget-hide button+1)
 				(widget-show button+1))))
-	  (table-attach table button column (1+ column) row (1+ row)))))
+	  (table-attach table button column (1+ column) row (1+ row)
+			:options '(:expand :fill)))))
     (widget-show-all table)))
 
 
@@ -302,91 +303,80 @@ (defun clamp (n min-val max-val)
   (declare (number n min-val max-val))
   (max (min n max-val) min-val))
 
+(defun set-cursor (spinner drawing-area label)
+  (let ((cursor
+	 (glib:int-enum
+	  (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
+	  'gdk:cursor-type)))
+    (setf (label-label label) (string-downcase cursor))
+    (setf (widget-cursor drawing-area) cursor)))
+
+(defun cursor-expose (drawing-area event)
+  (declare (ignore event))
+  (multiple-value-bind (width height)
+      (drawing-area-get-size drawing-area)
+    (let* ((window (widget-window drawing-area))
+	   (style (widget-style drawing-area))
+	   (white-gc (style-white-gc style))
+	   (gray-gc (style-bg-gc style :normal))
+	   (black-gc (style-black-gc style)))
+      (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
+      (gdk:draw-rectangle window black-gc t 0 (floor height 2) width 
+			  (floor height 2))
+      (gdk:draw-rectangle window gray-gc t (floor width 3) 
+			  (floor height 3) (floor width 3) 
+			  (floor height 3))))
+  t)
+
+(define-simple-dialog create-cursors (dialog "Cursors")
+  (let ((spinner (make-instance 'spin-button 
+		  :adjustment (adjustment-new 
+			       0 0 
+			       (1- (enum-int :last-cursor 'gdk:cursor-type))
+			       2 10 0)))
+	(drawing-area (make-instance 'drawing-area
+		       :width-request 80 :height-request 80
+		       :events '(:exposure-mask :button-press-mask)))
+	(label (make-instance 'label :label "XXX")))
+
+    (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
+
+    (signal-connect drawing-area 'button-press-event
+     #'(lambda (event)
+	 (case (gdk:event-button event)
+	   (1 (spin-button-spin spinner :step-forward 0.0))
+	   (3 (spin-button-spin spinner :step-backward 0.0)))
+	 t))
+
+    (signal-connect drawing-area 'scroll-event
+     #'(lambda (event)
+	 (case (gdk:event-direction event)
+	   (:up (spin-button-spin spinner :step-forward 0.0))
+	   (:down (spin-button-spin spinner :step-backward 0.0)))
+	 t))
+
+    (signal-connect spinner 'changed
+     #'(lambda ()
+	 (set-cursor spinner drawing-area label)))
 
-;; (defun set-cursor (spinner drawing-area label)
-;;   (let ((cursor
-;; 	 (glib:int-enum
-;; 	  (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
-;; 	  'gdk:cursor-type)))	
-;;     (setf (label-text label) (string-downcase cursor))
-;;     (setf (widget-cursor drawing-area) cursor)))
-    
-
-; (define-standard-dialog create-cursors "Cursors"
-;   (setf (container-border-width main-box) 10)
-;   (setf (box-spacing main-box) 5)
-;   (let* ((hbox (hbox-new nil 0))
-; 	 (label (create-label "Cursor Value : "))
-; 	 (adj (adjustment-new 0 0 152 2 10 0))
-; 	 (spinner (spin-button-new adj 0 0)))
-;     (setf (container-border-width hbox) 5)
-;     (box-pack-start main-box hbox nil t 0)
-;     (setf (misc-xalign label) 0)
-;     (setf (misc-yalign label) 0.5)
-;     (box-pack-start hbox label nil t 0)
-;     (box-pack-start hbox spinner t t 0)
-
-;     (let ((frame (make-frame
-; 		  :shadow-type :etched-in
-; 		  :label-xalign 0.5
-; 		  :label "Cursor Area"
-; 		  :border-width 10
-; 		  :parent main-box
-; 		  :visible t))
-; 	  (drawing-area (drawing-area-new)))
-;       (setf (widget-width drawing-area) 80)
-;       (setf (widget-height drawing-area) 80)
-;       (container-add frame drawing-area)
-;       (signal-connect
-;        drawing-area 'expose-event
-;        #'(lambda (event)
-; 	   (declare (ignore event))
-; 	   (multiple-value-bind (width height)
-; 	       (drawing-area-size drawing-area)
-; 	     (let* ((drawable (widget-window drawing-area))
-; 		    (style (widget-style drawing-area))
-; 		    (white-gc (style-get-gc style :white))
-; 		    (gray-gc (style-get-gc style :background :normal))
-; 		    (black-gc (style-get-gc style :black)))
-; 	       (gdk:draw-rectangle
-; 		drawable white-gc t 0 0 width (floor height 2))
-; 	       (gdk:draw-rectangle
-; 		drawable black-gc t 0 (floor height 2) width (floor height 2))
-; 	       (gdk:draw-rectangle
-; 		drawable gray-gc t (floor width 3) (floor height 3)
-; 		(floor width 3) (floor height 3))))
-; 	     t))
-;       (setf (widget-events drawing-area) '(:exposure :button-press))
-;       (signal-connect
-;        drawing-area 'button-press-event
-;        #'(lambda (event)
-; 	   (when (and
-; 		  (eq (gdk:event-type event) :button-press)
-; 		  (or
-; 		   (= (gdk:event-button event) 1)
-; 		   (= (gdk:event-button event) 3)))
-; 	     (spin-button-spin
-; 	      spinner
-; 	      (if (= (gdk:event-button event) 1)
-; 		  :step-forward
-; 		:step-backward)
-; 	      0)
-; 	     t)))
-;       (widget-show drawing-area)
-
-;     (let ((label (make-label
-; 		  :visible t
-; 		  :label "XXX"
-; 		  :parent main-box)))
-;       (setf (box-child-expand-p #|main-box|# label) nil)
-;       (signal-connect
-;        spinner 'changed
-;        #'(lambda ()
-; 	   (set-cursor spinner drawing-area label)))
-
-;       (widget-realize drawing-area)
-;       (set-cursor spinner drawing-area label)))))
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 5 :show-all t
+     :child (list
+	     (make-instance 'h-box
+	      :border-width 5
+	      :child (list
+		      (make-instance 'label :label "Cursor Value : ")
+		      :expand nil)
+	      :child spinner)
+	     :expand nil)
+     :child (make-instance 'frame
+;	     :shadow-type :etched-in
+	     :label "Cursor Area" :label-xalign 0.5 :border-width 10
+	     :child drawing-area)
+     :child (list label :expand nil))
 
+    (widget-realize drawing-area)
+    (set-cursor spinner drawing-area label)))
 
 
 ;;; Dialog
@@ -459,6 +449,16 @@ (define-simple-dialog create-entry (dialog "Entry")
     (widget-show-all main)))
 
 
+;; Expander
+
+(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
+  (make-instance 'v-box
+   :parent dialog :spacing 5 :border-width 5 :show-all t
+   :child (create-label "Expander demo. Click on the triangle for details.")
+   :child (make-instance 'expander
+	   :label "Details"
+	   :child (create-label "Details can be shown or hidden."))))
+
 
 ;; File chooser dialog
 
@@ -654,38 +654,32 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 
 ;;; Layout
 
-;; (defun layout-expose (layout event)
-;;   (with-slots (window x-offset y-offset) layout
-;;     (with-slots (x y width height) event
-;;       (let ((imin (truncate (+ x-offset x) 10))
-;; 	    (imax (truncate (+ x-offset x width 9) 10))
-;; 	    (jmin (truncate (+ y-offset y) 10))
-;; 	    (jmax (truncate (+ y-offset y height 9) 10)))
-;; 	(declare (fixnum imin imax jmin jmax))
-;; 	(gdk:window-clear-area window x y width height)
-
-;; 	(let ((window (layout-bin-window layout))
-;; 	      (gc (style-get-gc (widget-style layout) :black)))
-;; 	  (do ((i imin (1+ i)))
-;; 	      ((= i imax))
-;; 	    (declare (fixnum i))
-;; 	    (do ((j jmin (1+ j)))
-;; 		((= j jmax))
-;; 	      (declare (fixnum j))
-;; 	      (unless (zerop (mod (+ i j) 2))
-;; 		(gdk:draw-rectangle
-;; 		 window gc t
-;; 		 (- (* 10 i) x-offset) (- (* 10 j) y-offset)
-;; 		 (1+ (mod i 10)) (1+ (mod j 10))))))))))
-;;   t)
-
+(defun layout-expose (layout event)
+  (when (eq (gdk:event-window event) (layout-bin-window layout))
+    (with-slots (gdk:x gdk:y gdk:width gdk:height) event
+      (let ((imin (truncate gdk:x 10))
+	    (imax (truncate (+ gdk:x gdk:width 9) 10))
+	    (jmin (truncate gdk:y 10))
+	    (jmax (truncate (+ gdk:y gdk:height 9) 10)))
+
+	(let ((window (layout-bin-window layout))
+	      (gc (style-black-gc (widget-style layout))))
+	  (loop
+	   for i from imin below imax
+	   do (loop 
+	       for j from jmin below jmax
+	       unless (zerop (mod (+ i j) 2))
+	       do (gdk:draw-rectangle
+		   window gc t (* 10 i) (* 10 j) 
+		   (1+ (mod i 10)) (1+ (mod j 10)))))))))
+  nil)
 
 (define-toplevel create-layout (window "Layout" :default-width 200
 				                :default-height 200)
   (let ((layout (make-instance 'layout
 		 :parent (make-instance 'scrolled-window :parent window)
 		 :width 1600 :height 128000 :events '(:exposure-mask)
-;; 		 :signal (list 'expose-event #'layout-expose :object t)
+ 		 :signal (list 'expose-event #'layout-expose :object t)
 		 )))
 
     (with-slots (hadjustment vadjustment) layout
@@ -714,39 +708,94 @@ (define-toplevel create-layout (window "Layout" :default-width 200
 ;;; List    
     
 (define-simple-dialog create-list (dialog "List" :default-height 400)
-  (let ((store (make-instance 'list-store 
-		:column-types '(string int boolean)
-		:column-names '(:foo :bar :baz)
-		:initial-content '(#("First" 12321 nil)
-				   (:foo "Yeah" :baz t)))))
+  (let* ((store (make-instance 'list-store 
+		 :column-types '(string int boolean)
+		 :column-names '(:foo :bar :baz)
+		 :initial-content '(#("First" 12321 nil)
+				    (:foo "Yeah" :baz t))))
+	 (tree (make-instance 'tree-view :model store)))
 
     (loop
      with iter = (make-instance 'tree-iter)
      for i from 1 to 1000
      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
+    
+    (let ((column (make-instance 'tree-view-column :title "Column 1"))
+	  (cell (make-instance 'cell-renderer-text)))
+      (cell-layout-pack column cell :expand t)
+      (cell-layout-add-attribute column cell 'text (column-index store :foo))
+      (tree-view-append-column tree column))
+    
+    (let ((column (make-instance 'tree-view-column :title "Column 2"))
+	  (cell (make-instance 'cell-renderer-text :background "orange")))
+      (cell-layout-pack column cell :expand t)
+      (cell-layout-add-attribute column cell 'text (column-index store :bar))
+      (tree-view-append-column tree column))      
+    
+    (let ((column (make-instance 'tree-view-column :title "Column 3"))
+	  (cell (make-instance 'cell-renderer-text)))
+      (cell-layout-pack column cell :expand t)
+      (cell-layout-add-attribute column cell 'text (column-index store :baz))
+      (tree-view-append-column tree column))      
 
-    (let ((tree (make-instance 'tree-view :model store)))
-      (let ((column (make-instance 'tree-view-column :title "Column 1"))
-	    (cell (make-instance 'cell-renderer-text)))
-	(cell-layout-pack column cell)
-	(cell-layout-add-attribute column cell 'text (column-index store :foo))
-	(tree-view-append-column tree column))
-
-      (let ((column (make-instance 'tree-view-column :title "Column 2"))
-	    (cell (make-instance 'cell-renderer-text :background "orange")))
-	(cell-layout-pack column cell)
-	(cell-layout-add-attribute column cell 'text (column-index store :bar))
-	(tree-view-append-column tree column))      
-
-      (let ((column (make-instance 'tree-view-column :title "Column 3"))
-	    (cell (make-instance 'cell-renderer-text)))
-	(cell-layout-pack column cell)
-	(cell-layout-add-attribute column cell 'text (column-index store :baz))
-	(tree-view-append-column tree column))      
-
-      (make-instance 'scrolled-window 
-       :parent dialog :child tree :show-all t :border-width 10 
-       :hscrollbar-policy :automatic))))
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :child (list
+	     (make-instance 'h-box
+              :spacing 10
+	      :child (make-instance 'button
+		      :label "Remove Selection"
+		      :signal (list 'clicked
+			       #'(lambda ()
+				   (let ((references
+					  (mapcar
+					   #'(lambda (path)
+					       (make-instance 'tree-row-reference :model store :path path))					  
+					   (tree-selection-get-selected-rows
+					    (tree-view-selection tree)))))
+				     (mapc
+				      #'(lambda (reference)
+					  (list-store-remove store reference))
+				      references))))))
+	     :expand nil)
+     :child (list
+	     (make-instance 'h-box
+              :spacing 10
+	      :child (make-instance 'check-button 
+		      :label "Show Headers" :active t
+		      :signal (list 'toggled
+			       #'(lambda (button)
+				   (setf
+				    (tree-view-headers-visible-p tree)
+				    (toggle-button-active-p button)))
+			       :object t))
+	      :child (make-instance 'check-button 
+		      :label "Reorderable" :active nil
+		      :signal (list 'toggled
+			       #'(lambda (button)
+				   (setf
+				    (tree-view-reorderable-p tree)
+				    (toggle-button-active-p button)))
+			       :object t))
+	      :child (list 
+		      (make-instance 'h-box
+                       :child (make-instance 'label :label "Selection Mode: ")
+		       :child (make-instance 'combo-box
+			       :content '("Single" "Browse" "Multiple") 
+			       :active 0
+			       :signal (list 'changed
+				        #'(lambda (combo-box)
+					    (setf 
+					     (tree-selection-mode 
+					      (tree-view-selection tree))
+					     (svref 
+					      #(:single :browse :multiple)
+					      (combo-box-active combo-box))))
+					:object t)))
+		      :expand nil))
+	     :expand nil)
+     :child (make-instance 'scrolled-window 
+	    :child tree :hscrollbar-policy :automatic))))
 
 
 ;; Menus
@@ -997,25 +1046,25 @@ (defun create-pane-options (paned frame-label label1 label2)
 	 (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t 
 			              :parent frame)))
 
-    (table-attach table (create-label label1) 0 1 0 1)
+    (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
     (let ((check-button (make-instance 'check-button :label "Resize")))
-      (table-attach table check-button 0 1 1 2)
+      (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
       (signal-connect
        check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
     (let ((check-button (make-instance 'check-button :label "Shrink")))
-      (table-attach table check-button 0 1 2 3)
+      (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
       (setf (toggle-button-active-p check-button) t)
       (signal-connect
        check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
 
-    (table-attach table (create-label label2) 1 2 0 1)
+    (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
     (let ((check-button (make-instance 'check-button :label "Resize")))
-      (table-attach table check-button 1 2 1 2)
+      (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
       (setf (toggle-button-active-p check-button) t)
       (signal-connect
        check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
     (let ((check-button (make-instance 'check-button :label "Shrink")))
-      (table-attach table check-button 1 2 2 3)
+      (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
       (setf (toggle-button-active-p check-button) t)
       (signal-connect
        check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
@@ -1105,18 +1154,19 @@ (define-toplevel create-rulers (window "Rulers"
    (widget-events window) 
    '(:pointer-motion-mask :pointer-motion-hint-mask))
 
-  (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
-    (let ((ruler (make-instance 'h-ruler
+  (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
+	(h-ruler (make-instance 'h-ruler
 		  :metric :centimeters :lower 100.0d0 :upper 0.0d0
-		  :position 0.0d0 :max-size 20.0d0)))
-      (signal-connect window 'motion-notify-event #'widget-event :object ruler)
-      (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
-    (let ((ruler (make-instance 'v-ruler
+		  :position 0.0d0 :max-size 20.0d0))
+	(v-ruler (make-instance 'v-ruler
 	          :lower 5.0d0 :upper 15.0d0 
 		  :position 0.0d0 :max-size 20.0d0)))
-      (signal-connect window 'motion-notify-event #'widget-event :object ruler)
-      (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
-
+    (signal-connect window 'motion-notify-event
+     #'(lambda (event)
+	 (widget-event h-ruler event)
+	 (widget-event v-ruler event)))
+    (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
+    (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
 
 
 ;;; Scrolled window
@@ -1145,6 +1195,42 @@ (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
       (widget-show-all scrolled-window)))
 
 
+;;; Size group
+
+(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
+  (let ((size-group (make-instance 'size-group)))
+    (flet ((create-frame (label rows)
+	     (let ((table (make-instance 'table 
+			   :n-rows (length rows) :n-columns 2 :homogeneous nil
+			   :row-spacing 5 :column-spacing 10 :border-width 5)))
+	       (loop
+		for row in rows
+		for i from 0
+		do (table-attach table 
+		    (create-label (first row) :xalign 0 :yalign 1)
+		    0 1 i (1+ i) :x-options '(:expand :fill))
+		   (let ((combo (make-instance 'combo-box 
+				 :content (rest row) :active 0)))
+		     (size-group-add-widget size-group combo)
+		     (table-attach table combo 1 2 i (1+ i))))
+	       (make-instance 'frame :label label :child table))))
+
+      (make-instance 'v-box
+       :parent dialog :border-width 5 :spacing 5 :show-all t
+       :child (create-frame "Color Options"
+	       '(("Foreground" "Red" "Green" "Blue")
+		 ("Background" "Red" "Green" "Blue")))
+       :child (create-frame "Line Options"
+	       '(("Dashing" "Solid" "Dashed" "Dotted")
+		 ("Line ends" "Square" "Round" "Arrow")))
+       :child (create-check-button "Enable grouping"
+	       #'(lambda (active)
+		   (setf 
+		    (size-group-mode size-group) 
+		    (if active :horizontal :none)))
+	       t)))))
+
+
 ;;; Shapes
 
 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
@@ -1370,96 +1456,158 @@ (define-toplevel create-statusbar (window "Statusbar")
 
 ;;; Idle test
 
-;; (define-standard-dialog create-idle-test "Idle Test"
-;;   (let* ((container (make-instance 'hbox :parent main-box))
-;; 	 (label (make-instance 'label
-;; 		 :label "count: 0" :xpad 10 :ypad 10 :parent container))
-;; 	 (idle nil)
-;; 	 (count 0))
-;;     (declare (fixnum count))
-;;     (signal-connect
-;;      window 'destroy #'(lambda () (when idle (idle-remove idle))))
+(define-simple-dialog create-idle-test (dialog "Idle Test")
+  (let ((label (make-instance 'label
+		:label "count: 0" :xpad 10 :ypad 10))
+	(idle nil)
+	(count 0))
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when idle (idle-remove idle))))
  
-;;     (make-instance 'frame
-;;      :label "Label Container" :border-width 5 :parent main-box
-;;      :child
-;;      (make-instance 'v-box
-;;       :children
-;;       (create-radio-button-group
-;;        '(("Resize-Parent" :parent)
-;; 	 ("Resize-Queue" :queue)
-;; 	 ("Resize-Immediate" :immediate))
-;;        0
-;;        '(setf container-resize-mode) container)))
-
-;;     (make-instance 'button
-;;      :label "start" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (unless idle
-;; 	     (setq
-;; 	      idle
-;; 	      (idle-add
-;; 	       #'(lambda ()
-;; 		   (incf count)
-;; 		   (setf (label-label label) (format nil "count: ~D" count))
-;; 		   t))))))))
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :child label
+     :child (make-instance 'frame
+	     :label "Label Container" :border-width 5
+	     :child(make-instance 'v-box
+		   :children (create-radio-button-group
+			      '(("Resize-Parent" :parent)
+				("Resize-Queue" :queue)
+				("Resize-Immediate" :immediate))
+			      0
+			      #'(lambda (mode)
+ 				  (setf 
+ 				   (container-resize-mode (dialog-action-area dialog)) mode))))))
+
+    (dialog-add-button dialog "Start"
+     #'(lambda ()
+	 (unless idle
+	   (setq idle
+	    (idle-add
+	     #'(lambda ()
+		 (incf count)
+		 (setf (label-label label) (format nil "count: ~D" count))
+		 t))))))
       
-;;     (make-instance 'button
-;;      :label "stop" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (when idle
-;; 	     (idle-remove idle)
-;; 	     (setq idle nil))))))))
+    (dialog-add-button dialog "Stop"
+     #'(lambda ()
+	 (when idle
+	   (idle-remove idle)
+	   (setq idle nil))))))
     
 
 
 ;;; Timeout test
 
-;; (define-standard-dialog create-timeout-test "Timeout Test"
-;;   (let ((label (make-instance 'label
-;; 		:label "count: 0" :xpad 10 :ypad 10 :parent main-box))
-;; 	(timer nil)
-;; 	(count 0))
-;;     (declare (fixnum count))
-;;     (signal-connect
-;;      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
-          
-;;     (make-instance 'button
-;;      :label "start" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (unless timer
-;; 	     (setq
-;; 	      timer
-;; 	      (timeout-add
-;; 	       100
-;; 	       #'(lambda ()
-;; 		   (incf count)
-;; 		   (setf (label-label label) (format nil "count: ~D" count))
-;; 		   t))))))))
-
-;;     (make-instance 'button
-;;      :label "stop" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (when timer
-;; 	     (timeout-remove timer)
-;; 	     (setq timer nil))))))))
-  
+(define-simple-dialog create-timeout-test (dialog "Timeout Test")
+  (let ((label (make-instance 'label
+		:label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
+	(timer nil)
+	(count 0))
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when timer (timeout-remove timer))))
+
+    (dialog-add-button dialog "Start"
+     #'(lambda ()
+	 (unless timer
+	   (setq timer
+	    (timeout-add 100
+	     #'(lambda ()
+		 (incf count)
+		 (setf (label-label label) (format nil "count: ~D" count))
+		 t))))))
+
+    (dialog-add-button dialog "Stop"
+     #'(lambda ()
+	 (when timer
+	   (timeout-remove timer)
+	   (setq timer nil))))))
+
+
+;;; Text
+
+(define-simple-dialog create-text (dialog "Text" :default-width 400
+					         :default-height 400)
+  (let* ((text-view (make-instance 'text-view 
+		     :border-width 10 :visible t :wrap-mode :word))
+	 (buffer (text-view-buffer text-view))
+	 (active-tags ()))
+
+    (text-buffer-create-tag buffer "Bold" :weight :bold)
+    (text-buffer-create-tag buffer "Italic" :style :italic)
+    (text-buffer-create-tag buffer "Underline" :underline :single)
+    
+    (flet ((create-toggle-callback (tag-name)
+	     (let ((tag (text-tag-table-lookup 
+			 (text-buffer-tag-table buffer) tag-name)))
+	       #'(lambda (active)
+		   (unless (eq (and (find tag active-tags) t) active)
+		     ;; user activated
+		     (if active 
+			 (push tag active-tags)
+		       (setq active-tags (delete tag active-tags)))
+		     (multiple-value-bind (start end)
+			 (text-buffer-get-selection-bounds buffer)
+		       (if active 
+			   (text-buffer-apply-tag buffer tag start end)
+			 (text-buffer-remove-tag buffer tag start end))))))))
+
+      (let* ((actions 
+	      (make-instance 'action-group 
+	       :action (create-toggle-action 
+			"Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
+			(create-toggle-callback "Bold"))
+	       :action (create-toggle-action 
+			"Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
+			(create-toggle-callback "Italic"))
+	       :action (create-toggle-action 
+			"Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
+			(create-toggle-callback "Underline"))))
+	     (ui (make-instance 'ui-manager)))
+      
+	(ui-manager-insert-action-group ui actions)
+	(ui-manager-add-ui ui 
+	 '((:toolbar "ToolBar"
+	    (:toolitem "Bold")
+	    (:toolitem "Italic")
+	    (:toolitem "Underline"))))
+
+	;; Callback to activate/deactivate toolbar buttons when cursor
+	;; is moved
+	(signal-connect buffer 'mark-set
+	 #'(lambda (location mark)
+	     (declare (ignore mark))
+	     (text-tag-table-foreach (text-buffer-tag-table buffer)
+	      #'(lambda (tag)
+		  (let ((active
+			 (or 
+			  (and
+			   (text-iter-has-tag-p location tag)
+			   (not (text-iter-begins-tag-p location tag)))
+			  (text-iter-ends-tag-p location tag))))
+		    (unless (eq active (and (find tag active-tags) t))
+		      (if active 
+			  (push tag active-tags)
+			(setq active-tags (delete tag active-tags)))
+		      (setf 
+		       (toggle-action-active-p
+			(action-group-get-action actions (text-tag-name tag)))
+		       active)))))))
+
+	;; Callback to apply active tags when a character is inserted
+	(signal-connect buffer 'insert-text
+         #'(lambda (iter &rest args)
+	     (declare (ignore args))
+	     (let ((before (text-buffer-get-iter-at-offset buffer 
+			    (1- (text-iter-offset iter)))))
+	       (loop
+		for tag in active-tags
+		do (text-buffer-apply-tag buffer tag before iter))))
+	 :after t)
+	
+	(container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
+	(container-add dialog text-view)))))
+
 
 ;;; Toggle buttons
 
@@ -1584,66 +1732,92 @@ (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
 
 ;;; Tooltips test
 
-;; (define-standard-dialog create-tooltips "Tooltips"
-;;   (setf
-;;    (window-allow-grow-p window) t
-;;    (window-allow-shrink-p window) nil
-;;    (window-auto-shrink-p window) t
-;;    (widget-width window) 200
-;;    (container-border-width main-box) 10
-;;    (box-spacing main-box) 10)
-
-;;   (let ((tooltips (tooltips-new)))
-;;     (flet ((create-button (label tip-text tip-private)
-;; 	     (let ((button (make-instance 'toggle-button
-;; 		    :label label :parent main-box)))
-;; 	       (tooltips-set-tip tooltips button tip-text tip-private)
-;; 	       button)))
-;;       (create-button "button1" "This is button 1" "ContextHelp/button/1")
-;;       (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")
-
-;;       (let* ((toggle (create-button "Override TipSQuery Label"
-;; 				    "Toggle TipsQuery view" "Hi msw! ;)"))
-;; 	     (box (make-instance 'v-box
-;; 		   :homogeneous nil :spacing 5 :border-width 5
-;; 		   :parent (make-instance 'frame
-;; 	                    :label "ToolTips Inspector"
-;; 			    :label-xalign 0.5 :border-width 0
-;; 			    :parent main-box)))
-;; 	     (button (make-instance 'button :label "[?]" :parent box))
-;; 	     (tips-query (make-instance 'tips-query
-;; 			  :caller button :parent box)))
-
-;; 	(signal-connect
-;; 	 button 'clicked #'tips-query-start-query :object tips-query)
-	
-;; 	(signal-connect
-;; 	 tips-query 'widget-entered
-;; 	 #'(lambda (widget tip-text tip-private)
-;; 	     (declare (ignore widget tip-private))
-;; 	     (when (toggle-button-active-p toggle)
-;; 	       (setf
-;; 		(label-label tips-query)
-;; 		(if tip-text
-;; 		    "There is a Tip!"
-;; 		  "There is no Tip!"))
-;; 	       (signal-emit-stop tips-query 'widget-entered))))
-	
-;; 	(signal-connect
-;; 	 tips-query 'widget-selected
-;; 	 #'(lambda (widget tip-text tip-private event)
-;; 	     (declare (ignore tip-text event))
-;; 	     (when widget
-;; 	       (format
-;; 		t "Help ~S requested for ~S~%"
-;; 		(or tip-private "None") (type-of widget)))
-;; 	     t))
+(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
+  (let ((tooltips (make-instance 'tooltips)))
+    (flet ((create-button (label tip-text tip-private)
+	     (let ((button (make-instance 'toggle-button :label label)))
+	       (tooltips-set-tip tooltips button tip-text tip-private)
+	       button)))
+      (make-instance 'v-box
+       :parent dialog :border-width 10 :spacing 10 :show-all t
+       :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
+       :child (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
+
+
+;;; UI Manager
+
+(defvar *ui-description*
+  '((:menubar "MenuBar"
+     (:menu "FileMenu"
+      (:menuitem "New")
+      (:menuitem "Open")
+      (:menuitem "Save")
+      (:menuitem "SaveAs")
+      :separator
+      (:menuitem "Quit"))
+     (:menu "PreferencesMenu"
+       (:menu "ColorMenu"
+	(:menuitem "Red")
+ 	(:menuitem "Green")
+ 	(:menuitem "Blue"))
+       (:menu "ShapeMenu"
+        (:menuitem "Square")
+        (:menuitem "Rectangle")
+        (:menuitem "Oval"))
+       (:menuitem "Bold"))
+     (:menu "HelpMenu"
+      (:menuitem "About")))
+    (:toolbar "ToolBar"
+     (:toolitem "Open")
+     (:toolitem "Quit")
+     (:separator "Sep1")
+     (:toolitem "Logo"))))
+
+(define-toplevel create-ui-manager (window "UI Manager")
+  (let ((actions 
+	 (make-instance 'action-group 
+	  :name "Actions"
+	  :action (create-action "FileMenu" nil "_File")
+	  :action (create-action "PreferencesMenu" nil "_Preferences")
+	  :action (create-action "ColorMenu" nil "_Color")
+	  :action (create-action "ShapeMenu" nil "_Shape")
+	  :action (create-action "HelpMenu" nil "_Help")
+	  :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
+	  :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
+	  :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
+	  :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
+	  :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
+	  :action (create-action "About" nil "_About" "<control>A" "About")
+	  :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
+	  :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
+	  :actions (create-radio-actions
+		    '(("Red" nil "_Red" "<control>R" "Blood")
+		      ("Green" nil "_Green" "<control>G" "Grass")
+		      ("Blue" nil "_Blue" "<control>B" "Sky"))
+		    "Green")
+	  :actions (create-radio-actions
+		    '(("Square" nil "_Square" "<control>S" "Square")
+		      ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
+		      ("Oval" nil "_Oval" "<control>O" "Egg")))))
+	(ui (make-instance 'ui-manager)))
+  
+    (ui-manager-insert-action-group ui actions)
+    (ui-manager-add-ui ui *ui-description*)
 
-;; 	(tooltips-set-tip
-;; 	 tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
-;; 	(tooltips-set-tip
-;; 	 tooltips close-button "Push this button to close window"
-;; 	 "ContextHelp/buttons/Close")))))
+    (window-add-accel-group window (ui-manager-accel-group ui))
+    
+    (make-instance 'v-box 
+     :parent window :show-all t
+     :child (list 
+	     (ui-manager-get-widget ui "/MenuBar")
+	     :expand nil :fill nil)
+     :child (list 
+	     (ui-manager-get-widget ui "/ToolBar")
+	     :expand nil :fill nil)
+     :child (make-instance 'label
+	     :label "Type <alt> to start" 
+	     :xalign 0.5 :yalign 0.5
+	     :width-request 200 :height-request 200))))
 		  
 
 
@@ -1659,11 +1833,12 @@ (defun create-main-window ()
  	    ("calendar" create-calendar)
  	    ("check buttons" create-check-buttons)
  	    ("color selection" create-color-selection)
-;; 	    ("cursors" #|create-cursors|#)
+ 	    ("cursors" create-cursors)
  	    ("dialog" create-dialog)
 ;; ;  	    ("dnd")
  	    ("entry" create-entry)
 ;; 	    ("event watcher")
+ 	    ("enxpander" create-expander)
  	    ("file chooser" create-file-chooser)
 ;; 	    ("font selection")
 ;; 	    ("handle box" create-handle-box)
@@ -1684,19 +1859,21 @@ (defun create-main-window ()
  	    ("rulers" create-rulers)
 ;; 	    ("saved position")
  	    ("scrolled windows" create-scrolled-windows)
+	    ("size group" create-size-group)
 ;; 	    ("shapes" create-shapes)
  	    ("spinbutton" create-spins)
  	    ("statusbar" create-statusbar)
-;; 	    ("test idle" create-idle-test)
+ 	    ("test idle" create-idle-test)
 ;; 	    ("test mainloop")
 ;; 	    ("test scrolling")
 ;; 	    ("test selection")
-;; 	    ("test timeout" create-timeout-test)
-;; 	    ("text" #|create-text|#)
+ 	    ("test timeout" create-timeout-test)
+ 	    ("text" create-text)
  	    ("toggle buttons" create-toggle-buttons)
  	    ("toolbar" create-toolbar)
-;; 	    ("tooltips" create-tooltips)
+ 	    ("tooltips" create-tooltips)
 ;; 	    ("tree" #|create-tree|#)
+	    ("UI manager" create-ui-manager)
 ))
 	(main-window (make-instance 'window
 		      :title "testgtk.lisp" :name "main_window"