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

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index fa01312..970f311 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -1,41 +1,53 @@
-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
 ;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
 ;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
 ;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: testgtk.lisp,v 1.7 2004-11-21 17:58:28 espen Exp $
+;; Parts of this file are direct translations of code from 'testgtk.c'
+;; distributed with the Gtk+ library, and thus covered by the GNU
+;; Lesser General Public License and copyright Peter Mattis, Spencer
+;; Kimball, Josh MacDonald and others.
 
 
-;;; Some of the code in this file are really outdatet, but it is
-;;; still the most complete example of how to use the library
+;; $Id: testgtk.lisp,v 1.31 2005-04-25 18:13:32 espen Exp $
 
+#+sbcl(require :gtk)
+#+cmucl(asdf:oos 'asdf:load-op :gtk)
 
-;(use-package "GTK")
-(in-package "GTK")
+(defpackage "TESTGTK"
+  (:use "COMMON-LISP" "GTK"))
+
+(in-package "TESTGTK")
 
 (defmacro define-toplevel (name (window title &rest initargs) &body body)
   `(let ((,window nil))
      (defun ,name ()
        (unless ,window
-	 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
+	 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
 	 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
 	 ,@body)
        
-       (if (not (widget-visible-p ,window))
-	   (widget-show-all ,window)
-	 (widget-hide ,window)))))
+       (when ,window
+	 (if (not (widget-visible-p ,window))
+	     (widget-show ,window)
+	   (widget-hide ,window))))))
 
 
 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
@@ -44,19 +56,20 @@ (defmacro define-dialog (name (dialog title &optional (class 'dialog)
   `(let ((,dialog nil))
      (defun ,name ()
        (unless ,dialog
-	 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
+	 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
 	 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
 	 ,@body)
        
-       (if (not (widget-visible-p ,dialog))
-	   (widget-show ,dialog)
-	 (widget-hide ,dialog)))))
+       (when ,dialog
+	 (if (not (widget-visible-p ,dialog))
+	     (widget-show ,dialog)
+	   (widget-hide ,dialog))))))
 
 
 (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)))
 
 
 
@@ -183,14 +196,13 @@ (defun create-bbox-in-frame (class frame-label spacing width height layout)
    :label frame-label
    :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 :stock "gtk-ok")
+	   :child (make-instance 'button :stock "gtk-cancel")
+	   :child (make-instance 'button :stock "gtk-help"))))
 
 (define-toplevel create-button-box (window "Button Boxes")
   (make-instance 'v-box
-   :parent window :border-width 10 :spacing 10 :show-all t
+   :parent window :border-width 10 :spacing 10
    :child (make-instance 'frame
 	   :label "Horizontal Button Boxes"
 	   :child (make-instance 'v-box
@@ -238,15 +250,15 @@ (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)))))
-    (widget-show-all table)))
+	  (table-attach table button column (1+ column) row (1+ row)
+			:options '(:expand :fill)))))))
 
 
 ;; Calenadar
 
 (define-simple-dialog create-calendar (dialog "Calendar")
   (make-instance 'v-box
-   :parent dialog :border-width 10 :show-all t
+   :parent dialog :border-width 10
    :child (make-instance 'calendar)))
 
 
@@ -254,7 +266,7 @@ (define-simple-dialog create-calendar (dialog "Calendar")
 
 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
   (make-instance 'v-box
-   :border-width 10 :spacing 10 :parent dialog :show-all t
+   :border-width 10 :spacing 10 :parent dialog
    :children (loop
 	      for n from 1 to 3
 	      collect (make-instance 'check-button
@@ -266,25 +278,22 @@ (define-simple-dialog create-check-buttons (dialog "Check Buttons")
 
 (define-dialog create-color-selection (dialog "Color selection dialog" 
 				       'color-selection-dialog
-				       :allow-grow nil :allow-shrink nil)
-  (with-slots (action-area colorsel) dialog
-;;     This seg faults for some unknown reason
-;;     (let ((button (make-instance 'check-button :label "Show Palette")))
-;;       (dialog-add-action-widget dialog button
-;;        #'(lambda () 
-;;  	  (setf 
-;;  	   (color-selection-has-palette-p colorsel)
-;;  	   (toggle-button-active-p button)))))
-
-    (container-add action-area 
-     (create-check-button "Show Opacity" 
-      #'(lambda (state)
-	  (setf (color-selection-has-opacity-control-p colorsel) state))))
-
-    (container-add action-area
-     (create-check-button "Show Palette" 
-      #'(lambda (state) 
-	  (setf (color-selection-has-palette-p colorsel) state))))
+				       :allow-grow nil :allow-shrink nil
+				       :show-children nil)
+  (with-slots (colorsel) dialog
+    (let ((button (make-instance 'check-button :label "Show Opacity")))
+      (dialog-add-action-widget dialog button
+       #'(lambda () 
+ 	  (setf 
+ 	   (color-selection-has-opacity-control-p colorsel)
+ 	   (toggle-button-active-p button)))))
+
+    (let ((button (make-instance 'check-button :label "Show Palette")))
+      (dialog-add-action-widget dialog button
+       #'(lambda () 
+ 	  (setf 
+ 	   (color-selection-has-palette-p colorsel)
+ 	   (toggle-button-active-p button)))))
 
     (signal-connect dialog :ok
      #'(lambda ()
@@ -302,91 +311,79 @@ (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)
+      (widget-get-size-allocation 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- (glib:enum-int :last-cursor 'gdk:cursor-type))
+			       2 10 0)))
+	(drawing-area (make-instance 'drawing-area
+		       :width-request 80 :height-request 80
+		       :events '(:exposure :button-press)))
+	(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))
+	   (3 (spin-button-spin spinner :step-backward)))
+	 t))
+
+    (signal-connect drawing-area 'scroll-event
+     #'(lambda (event)
+	 (case (gdk:event-direction event)
+	   (:up (spin-button-spin spinner :step-forward))
+	   (:down (spin-button-spin spinner :step-backward)))
+	 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
+     :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
+	     :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
@@ -455,151 +452,166 @@ (define-simple-dialog create-entry (dialog "Entry")
       
 	(create-check-button "Editable" 'editable)
 	(create-check-button "Visible" 'visibility)
-	(create-check-button "Sensitive" 'sensitive)))
-    (widget-show-all main)))
+	(create-check-button "Sensitive" 'sensitive)))))
+
+
+;; Expander
 
+(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
+  (make-instance 'v-box
+   :parent dialog :spacing 5 :border-width 5
+   :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
 
 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
+  (file-chooser-add-filter dialog 
+   (make-instance 'file-filter :name "All files" :pattern "*"))
+  (file-chooser-add-filter dialog 
+   (make-instance 'file-filter :name "Common Lisp source code" 
+    :patterns '("*.lisp" "*.lsp")))
+
   (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
   (dialog-add-button dialog "gtk-ok" 
    #'(lambda ()
-       (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+       (if (slot-boundp dialog 'filename)	   
+	   (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+	 (write-line "No files selected"))
        (widget-destroy dialog))))
 
 
-
-;;; Handle box
-
-;; (defun create-handle-box-toolbar ()
-;;   (let ((toolbar (toolbar-new :horizontal :both)))
-;;     (toolbar-append-item
-;;      toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Horizontal toolbar layout"
-;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
-
-;;     (toolbar-append-item
-;;      toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Vertical toolbar layout"
-;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
-
-;;     (toolbar-append-space toolbar)
-    
-;;     (toolbar-append-item
-;;      toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Only show toolbar icons"
-;;      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
-    
-;;     (toolbar-append-item
-;;      toolbar "Text" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Only show toolbar text"
-;;      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
-  
-;;     (toolbar-append-item
-;;      toolbar "Both" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Show toolbar icons and text"
-;;      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
-
-;;     (toolbar-append-space toolbar)
-
-;;     (toolbar-append-item
-;;      toolbar "Small" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Use small spaces"
-;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
-    
-;;     (toolbar-append-item
-;;      toolbar "Big" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Use big spaces"
-;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
-    
-;;     (toolbar-append-space toolbar)
-
-;;     (toolbar-append-item
-;;      toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Enable tooltips"
-;;      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
-
-;;     (toolbar-append-item
-;;      toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Disable tooltips"
-;;      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
-
-;;     (toolbar-append-space toolbar)
-
-;;     (toolbar-append-item
-;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Show borders"
-;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
-    
-;;     (toolbar-append-item
-;;      toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Hide borders"
-;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
-
-;;     toolbar))
-
-
-;; (defun handle-box-child-signal (handle-box child action)
-;;   (format t "~S: child ~S ~A~%" handle-box child action))
-
-
-;; (define-test-window create-handle-box "Handle Box Test"
-;;   (setf (window-allow-grow-p window) t)
-;;   (setf (window-allow-shrink-p window) t)
-;;   (setf (window-auto-shrink-p window) nil)
-;;   (setf (container-border-width window) 20)
-;;   (let ((v-box (v-box-new nil 0)))
-;;     (container-add window v-box)
-
-;;     (container-add v-box (create-label "Above"))
-;;     (container-add v-box (hseparator-new))
-
-;;     (let ((hbox (hbox-new nil 10)))
-;;       (container-add v-box hbox)
+;; Font selection dialog
+
+(define-toplevel create-font-selection (window "Font Button" :resizable nil)
+  (make-instance 'h-box 
+   :parent window :spacing 8 :border-width 8
+   :child (make-instance 'label :label "Pick a font")
+   :child (make-instance 'font-button 
+           :use-font t :title "Font Selection Dialog")))
+
+
+;;; Icon View
+
+#+gtk2.6
+(let ((file-pixbuf nil)
+      (folder-pixbuf nil))
+  (defun load-pixbufs ()
+    (unless file-pixbuf
+      (handler-case 
+          (setf
+	   file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
+	   folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
+	(glib:glib-error (condition)
+	  (make-instance 'message-dialog 
+	   :message-type :error :visible t
+	   :text "<b>Failed to load an image</b>" 
+	   :secondary-text (glib:gerror-message condition)
+	   :signal (list :close #'widget-destroy :object t))
+	  (return-from load-pixbufs nil))))
+    t)
+
+  (defun fill-store (store directory)
+    (list-store-clear store)
+    (let ((dir #+cmu(unix:open-dir directory)
+	       #+sbcl(sb-posix:opendir directory)))
+      (unwind-protect 
+	  (loop
+	   as filename = #+cmu(unix:read-dir dir)
+	                 #+sbcl(let ((dirent (sb-posix:readdir dir)))
+				 (unless (sb-grovel::foreign-nullp dirent)
+				   (sb-posix:dirent-name dirent)))
+	   while filename
+	   unless (or (equal filename ".") (equal filename ".."))
+	   do (let* ((pathname (format nil "~A~A" directory filename))
+		     (directory-p
+		      #+cmu(eq (unix:unix-file-kind pathname) :directory)
+		      #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
+		(list-store-append store 
+		 (vector
+		  filename 
+		  (if directory-p folder-pixbuf file-pixbuf)
+		  directory-p))))
+	#+cmu(unix:close-dir dir)
+	#+sbcl(sb-posix:closedir dir))))
+
+  (defun sort-func (store a b)
+    (let ((a-dir-p (tree-model-value store a 'directory-p))
+	  (b-dir-p (tree-model-value store b 'directory-p))
+	  (a-name (tree-model-value store a 'filename))
+	  (b-name (tree-model-value store b 'filename)))
+      (cond
+       ((and a-dir-p (not b-dir-p)) :before)
+       ((and (not a-dir-p) b-dir-p) :after)
+       ((string< a-name b-name) :before)
+       ((string> a-name b-name) :after)
+       (t :equal))))
+
+  (defun parent-dir (dir)
+    (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
+      (subseq dir 0 end)))
+
+  (define-toplevel create-icon-view (window "Icon View demo"
+				     :default-width 650 
+				     :default-height 400)
+    (if (not (load-pixbufs))
+	(widget-destroy window)
+      (let* ((directory "/")
+	     (store (make-instance 'list-store 
+		     :column-types '(string gdk:pixbuf boolean)
+		     :column-names '(filename pixbuf directory-p)))
+	     (icon-view (make-instance 'icon-view
+			 :model store :selection-mode :multiple
+			 :text-column 'filename :pixbuf-column 'pixbuf))
+	     (up (make-instance 'tool-button 
+		  :stock "gtk-go-up" :is-important t :sensitive nil))
+	     (home (make-instance 'tool-button 
+		    :stock  "gtk-home" :is-important t)))
+	(tree-sortable-set-sort-func store :default #'sort-func)
+	(tree-sortable-set-sort-column store :default :ascending)
+	(fill-store store directory)
+
+	(signal-connect icon-view 'item-activated
+         #'(lambda (path)
+	     (when (tree-model-value store path 'directory-p)
+	       (setq directory
+		     (concatenate 'string directory (tree-model-value store path 'filename) "/"))
+	       (fill-store store directory)
+	       (setf (widget-sensitive-p up) t))))
+
+	(signal-connect up 'clicked
+	 #'(lambda ()
+	     (unless (string= directory "/")
+	       (setq directory (parent-dir directory))
+	       (fill-store store directory)
+	       (setf 
+		(widget-sensitive-p home)
+		(not (string= directory (namestring (truename #p"clg:")))))
+	       (setf (widget-sensitive-p up) (not (string= directory "/"))))))
+
+	(signal-connect home 'clicked
+         #'(lambda ()
+	     (setq directory (namestring (truename #p"clg:")))
+	     (fill-store store directory)
+	     (setf (widget-sensitive-p up) t)
+	     (setf (widget-sensitive-p home) nil)))
       
-;;       (let ((handle-box (handle-box-new)))
-;; 	(box-pack-start hbox handle-box nil nil 0)
-;; 	(signal-connect
-;; 	 handle-box 'child-attached
-;; 	 #'(lambda (child)
-;; 	     (handle-box-child-signal handle-box child "attached")))
-;; 	(signal-connect
-;; 	 handle-box 'child-detached
-;; 	 #'(lambda (child)
-;; 	     (handle-box-child-signal handle-box child "detached")))
-;; 	(container-add handle-box (create-handle-box-toolbar)))
-
-;;       (let ((handle-box (handle-box-new)))
-;; 	(box-pack-start hbox handle-box nil nil 0)
-;; 	(signal-connect
-;; 	 handle-box 'child-attached
-;; 	 #'(lambda (child)
-;; 	     (handle-box-child-signal handle-box child "attached")))
-;; 	(signal-connect
-;; 	 handle-box 'child-detached
-;; 	 #'(lambda (child)
-;; 	     (handle-box-child-signal handle-box child "detached")))
-
-;; 	(let ((handle-box2 (handle-box-new)))
-;; 	  (container-add handle-box handle-box2)
-;; 	  (signal-connect
-;; 	   handle-box2 'child-attached
-;; 	   #'(lambda (child)
-;; 	       (handle-box-child-signal handle-box child "attached")))
-;; 	  (signal-connect
-;; 	   handle-box2 'child-detached
-;; 	   #'(lambda (child)
-;; 	       (handle-box-child-signal handle-box child "detached")))
-;; 	  (container-add handle-box2 (create-label "Foo!")))))
-    
-;;     (container-add v-box (hseparator-new))
-;;     (container-add v-box (create-label "Below"))))
+	(make-instance 'v-box 
+         :parent window
+	 :child (list
+		 (make-instance 'toolbar :child up :child home)		 
+		 :fill nil :expand nil)
+	 :child (make-instance 'scrolled-window
+	         :shadow-type :etched-in :policy :automatic
+		 :child icon-view))))))
+
 
 ;;; Image
 
-(define-toplevel create-image (window "Image")
+(define-toplevel create-image (window "Image" :resizable nil)
   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 
 
@@ -646,47 +658,41 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
                       :justify :fill :wrap t)
 
 	     :child (create-label-in-frame "Underlined label"
+(#+cmu glib:latin1-to-unicode #+sbcl identity
 "This label is underlined!
-This one is underlined (こんにちは) in quite a funky fashion"
+This one is underlined (æøåÆØÅ) in quite a funky fashion")
                       :justify :left
 	              :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 
 
 ;;; 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)
-		 )))
+		 :width 1600 :height 128000 :events '(:exposure)
+ 		 :signal (list 'expose-event #'layout-expose :object t))))
 
     (with-slots (hadjustment vadjustment) layout
       (setf
@@ -696,18 +702,22 @@ (define-toplevel create-layout (window "Layout" :default-width 200
     (dotimes (i 16)
       (dotimes (j 16)
 	(let ((text (format nil "Button ~D, ~D" i j)))
-	  (make-instance (if (not (zerop (mod (+ i j) 2)))
-			     'button
-			   'label)
-	   :label text :parent (list layout :x (* j 100) :y (* i 100))))))
+	  (layout-put layout
+	   (make-instance (if (not (zerop (mod (+ i j) 2)))
+			      'button
+			    'label)
+			  :label text :visible t)
+	   (* j 100) (* i 100)))))
 
     (loop
      for i from 16 below 1280
      do (let ((text (format nil "Button ~D, ~D" i 0)))
-	  (make-instance (if (not (zerop (mod i 2)))
-			     'button
-			   'label)
-	   :label text :parent (list layout :x 0 :y (* i 100)))))))
+	  (layout-put layout
+	   (make-instance (if (not (zerop (mod i 2)))
+			      'button
+			    'label)
+			  :label text :visible t)
+	   0 (* i 100))))))
 
 
 
@@ -715,7 +725,7 @@ (define-toplevel create-layout (window "Layout" :default-width 200
     
 (define-simple-dialog create-list (dialog "List" :default-height 400)
   (let* ((store (make-instance 'list-store 
-		 :column-types '(string int boolean)
+		 :column-types '(string integer boolean)
 		 :column-names '(:foo :bar :baz)
 		 :initial-content '(#("First" 12321 nil)
 				    (:foo "Yeah" :baz t))))
@@ -745,7 +755,7 @@ (define-simple-dialog create-list (dialog "List" :default-height 400)
       (tree-view-append-column tree column))      
 
     (make-instance 'v-box
-     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :parent dialog :border-width 10 :spacing 10
      :child (list
 	     (make-instance 'h-box
               :spacing 10
@@ -818,14 +828,16 @@ (defun create-menu (depth tearoff)
 		 (make-instance 'radio-menu-item
 		  :label (format nil "item ~2D - ~D" depth (1+ i)))))
  	    (if group
- 		(radio-menu-item-add-to-group menu-item group)
+ 		(add-to-radio-group menu-item group)
  	      (setq group menu-item))
 	    (unless (zerop (mod depth 2))
 	      (setf (check-menu-item-active-p menu-item) t))
 	    (menu-shell-append menu menu-item)
 	    (when (= i 3)
 	      (setf (widget-sensitive-p menu-item) nil))
-	    (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
+	    (let ((submenu (create-menu (1- depth) t)))
+	      (when submenu
+		(setf (menu-item-submenu menu-item) submenu))))))
       menu)))
 
 
@@ -833,7 +845,7 @@ (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
   (let* ((main (make-instance 'v-box :parent dialog))
 ;	 (accel-group (make-instance 'accel-group))
 	 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
-;    (accel-group-attach accel-group window)
+;    (window-add-accel-group dialog accel-group)
 
     (let ((menu-item (make-instance 'menu-item 
 		      :label (format nil "test~%line2"))))
@@ -862,7 +874,7 @@ (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 
 ;;; Notebook
 
-(defun create-notebook-page (notebook page-num)
+(defun create-notebook-page (notebook page-num book-closed)
   (let* ((title (format nil "Page ~D" page-num))
 	 (page (make-instance 'frame :label title :border-width 10))
  	 (v-box (make-instance 'v-box 
@@ -902,14 +914,14 @@ (defun create-notebook-page (notebook page-num)
 	     :signal (list 'clicked #'(lambda () (widget-hide page)))))
 
     (let ((label-box (make-instance 'h-box 
-		      :show-all t
+		      :show-children t
 		      :child-args '(:expand nil)
-		      :child (make-instance 'image :pixmap book-closed-xpm)
+		      :child (make-instance 'image :pixbuf book-closed)
 		      :child (make-instance 'label :label title)))
 	  (menu-box (make-instance 'h-box 
-		     :show-all t
+		     :show-children t
 		     :child-args '(:expand nil)
-		     :child (make-instance 'image :pixmap book-closed-xpm)
+		     :child (make-instance 'image :pixbuf book-closed)
 		     :child (make-instance 'label :label title))))
 
       (widget-show-all page)
@@ -918,24 +930,25 @@ (defun create-notebook-page (notebook page-num)
 
 (define-simple-dialog create-notebook (dialog "Notebook")
   (let ((main (make-instance 'v-box :parent dialog)))
-    (let ((notebook (make-instance 'notebook 
+    (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
+	  (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
+	  (notebook (make-instance 'notebook 
 		     :border-width 10 :tab-pos :top :parent main)))
-      (flet ((set-image (page func xpm)
-	       (image-set-from-pixmap-data 
-		(first (container-children (funcall func notebook page)))
-		xpm)))	     
+      (flet ((set-image (page func pixbuf)
+	       (setf
+		(image-pixbuf 
+		 (first (container-children (funcall func notebook page))))
+		pixbuf)))
 	(signal-connect notebook 'switch-page
 	 #'(lambda (pointer page)
 	     (declare (ignore pointer))
-	     (unless (eq page (notebook-current-page-num notebook))
-	       (set-image page #'notebook-menu-label book-open-xpm)
-	       (set-image page #'notebook-tab-label book-open-xpm)
-	     
+	     (set-image page #'notebook-menu-label book-open)
+	     (set-image page #'notebook-tab-label book-open)
+	     (when (slot-boundp notebook 'current-page)
 	       (let ((curpage (notebook-current-page notebook)))
-		 (when curpage
-		   (set-image curpage #'notebook-menu-label book-closed-xpm)
-		   (set-image curpage #'notebook-tab-label book-closed-xpm)))))))	  
-      (loop for i from 1 to 5 do (create-notebook-page notebook i))
+		 (set-image curpage #'notebook-menu-label book-closed)
+		 (set-image curpage #'notebook-tab-label book-closed))))))
+      (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 
       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 	
@@ -966,7 +979,6 @@ (define-simple-dialog create-notebook (dialog "Notebook")
        :child-args '(:expand nil)
        :child (make-instance 'label :label "Notebook Style: ")
        :child (let ((scrollable-p nil)) 
-		;; option menu is deprecated, we should use combo-box
 		(make-instance 'combo-box
 		 :content '("Standard" "No tabs" "Scrollable") :active 0
 		 :signal (list 'changed
@@ -992,7 +1004,7 @@ (define-simple-dialog create-notebook (dialog "Notebook")
 				   (setf (notebook-show-tabs-p notebook) t)
 				   (setf (notebook-scrollable-p notebook) t)
 				   (loop for i from 6 to 15 
-				    do (create-notebook-page notebook i))))))
+				    do (create-notebook-page notebook i book-closed))))))
 			  :object t)))
        :child (make-instance 'button
 	       :label "Show all Pages"
@@ -1024,64 +1036,40 @@ (define-simple-dialog create-notebook (dialog "Notebook")
 ;;; Panes
 
 (defun toggle-resize (child)
-  (let* ((paned (widget-parent child))
-	 (is-child1-p (eq child (paned-child1 paned))))
-    (multiple-value-bind (child resize shrink)
-	(if is-child1-p
-	    (paned-child1 paned)
-	  (paned-child2 paned))
-      (container-remove paned child)
-      (if is-child1-p
-	  (paned-pack1 paned child (not resize) shrink)
-	(paned-pack2 paned child (not resize) shrink)))))
+  (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
 
 (defun toggle-shrink (child)
-  (let* ((paned (widget-parent child))
-	 (is-child1-p (eq child (paned-child1 paned))))
-    (multiple-value-bind (child resize shrink)
-	(if is-child1-p
-	    (paned-child1 paned)
-	  (paned-child2 paned))
-      (container-remove paned child)
-      (if is-child1-p
-	  (paned-pack1 paned child resize (not shrink))
-	(paned-pack2 paned child resize (not shrink))))))
+  (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
 
 (defun create-pane-options (paned frame-label label1 label2)
-  (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
-	 (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t 
-			              :parent frame)))
-
-    (table-attach table (create-label label1) 0 1 0 1)
+  (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
+    (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)
-      (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)
-      (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)
-    (let ((check-button (make-instance 'check-button :label "Resize")))
-      (table-attach table check-button 1 2 1 2)
-      (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)
-      (setf (toggle-button-active-p check-button) t)
-      (signal-connect
-       check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
-    frame))
+      (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" :active t)))
+      (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
+      (signal-connect check-button 'toggled 
+       #'toggle-shrink :object (paned-child1 paned)))
+
+    (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
+    (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
+      (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
+      (signal-connect check-button 'toggled 
+       #'toggle-resize :object (paned-child2 paned)))
+    (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
+      (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
+      (signal-connect check-button 'toggled
+       #'toggle-shrink :object (paned-child2 paned)))
+    (make-instance 'frame :label frame-label :border-width 4 :child table)))
 
 (define-toplevel create-panes (window "Panes")
   (let* ((hpaned (make-instance 'h-paned
 		  :child1 (make-instance 'frame
 			   :width-request 60 :height-request 60
 			   :shadow-type :in 
-			   :child (make-instance 'buttun :label "Hi there"))
+			   :child (make-instance 'button :label "Hi there"))
 		  :child2 (make-instance 'frame			    
 			   :width-request 80 :height-request 60
 			   :shadow-type :in)))
@@ -1102,15 +1090,39 @@ (define-toplevel create-panes (window "Panes")
 
 ;;; Progress bar
 
-     
+(define-simple-dialog create-progress-bar (dialog "Progress Bar")
+  (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
+	 (activity-mode-button (make-instance 'check-button 
+				:label "Activity mode"))
+	 (timer (timeout-add 100
+		 #'(lambda ()
+		     (if (toggle-button-active-p activity-mode-button)
+			 (progress-bar-pulse progress)
+		       (let ((fract (+ (progress-bar-fraction progress) 0.01)))
+			 (setf		      
+			  (progress-bar-fraction progress)
+			  (if (> fract 1.0)
+			      0.0
+			    fract))))
+		     t))))
+
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 10
+     :child progress
+     :child activity-mode-button)
+
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when timer (timeout-remove timer))))))
 
 
 ;;; Radio buttons
 
 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
   (make-instance 'v-box
-   :parent dialog :border-width 10 :spacing 10 :show-all t
-   :children (create-radio-button-group '("button1" "button2" "button3") 1)))
+   :parent dialog :border-width 10 :spacing 10
+   :children (make-radio-group 'radio-button
+	      '((:label "button1") (:label "button2") (:label "button3"))
+	      nil)))
 
 
 ;;; Rangle controls
@@ -1118,7 +1130,7 @@ (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
 (define-simple-dialog create-range-controls (dialog "Range controls")
   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
     (make-instance 'v-box
-     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :parent dialog :border-width 10 :spacing 10
      :child (make-instance 'h-scale
 	     :width-request 150 :adjustment adjustment :inverted t
 	     :update-policy :delayed :digits 1 :draw-value t)
@@ -1131,7 +1143,7 @@ (define-simple-dialog create-range-controls (dialog "Range controls")
 (define-simple-dialog create-reparent (dialog "Reparent")
   (let ((main (make-instance 'h-box 
 	       :homogeneous t :spacing 10 :border-width 10 :parent dialog))
-	(label (make-instance 'label :label "Hellow World")))
+	(label (make-instance 'label :label "Hello World")))
 
     (flet ((create-frame (title)
 	     (let* ((frame (make-instance 'frame :label title :parent main))
@@ -1153,25 +1165,20 @@ (define-simple-dialog create-reparent (dialog "Reparent")
 
 (define-toplevel create-rulers (window "Rulers" 
 				:default-width 300 :default-height 300
-;;  				:events '(:pointer-motion-mask 
-;;  					  :pointer-motion-hint-mask)
-				)
-  (setf 
-   (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
+  				:events '(:pointer-motion :pointer-motion-hint))
+  (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
@@ -1200,88 +1207,117 @@ (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
+       :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)
-;;   (let* ((window
-;; 	  (make-instance 'window
-;; 	   :type type :x x :y y
-;; 	   :events '(:button-motion :pointer-motion-hint :button-press)))
-;; 	 (fixed
-;; 	  (make-instance 'fixed
-;; 	   :parent window :width 100 :height 100)))
+(defun create-shape-icon (xpm-file x y px py type root-window destroy)
+  (let ((window
+	 (make-instance 'window
+	  :type type :default-width 100 :default-height 100
+	  :events '(:button-motion :pointer-motion-hint :button-press)
+	  :signal (list 'destroy destroy))))
       
-;;     (widget-realize window)
-;;     (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
-;;       (let ((pixmap (pixmap-new source mask))
-;; 	    (x-offset 0)
-;; 	    (y-offset 0))
-;; 	(declare (fixnum x-offset y-offset))
-;; 	(fixed-put fixed pixmap px py)
-;; 	(widget-shape-combine-mask window mask px py)
+    (widget-realize window)
+    (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
+      (let ((fixed (make-instance 'fixed :parent window)))
+	(fixed-put fixed (create-image-widget source mask) px py))
+      (widget-shape-combine-mask window mask px py))
 	
-;; 	(signal-connect window 'button-press-event
-;; 	 #'(lambda (event)
-;; 	     (when (typep event 'gdk:button-press-event)
-;; 	       (setq x-offset (truncate (gdk:event-x event)))
-;; 	       (setq y-offset (truncate (gdk:event-y event)))
-;; 	       (grab-add window)
-;; 	       (gdk:pointer-grab
-;; 		(widget-window window) t
-;; 		'(:button-release :button-motion :pointer-motion-hint)
-;; 		nil nil 0))
-;; 	     t))
-
-;; 	(signal-connect window 'button-release-event
-;; 	 #'(lambda (event)
-;; 	     (declare (ignore event))
-;; 	     (grab-remove window)
-;; 	     (gdk:pointer-ungrab 0)
-;; 	     t))
+    (let ((x-offset 0)
+	  (y-offset 0))
+      (declare (fixnum x-offset y-offset))
+      (signal-connect window 'button-press-event
+       #'(lambda (event)
+	   (when (typep event 'gdk:button-press-event)
+	     (setq x-offset (truncate (gdk:event-x event)))
+	     (setq y-offset (truncate (gdk:event-y event)))
+	     (grab-add window)
+	     (gdk:pointer-grab (widget-window window) 
+	      :events '(:button-release :button-motion :pointer-motion-hint)
+	      :owner-events t))))
+
+      (signal-connect window 'button-release-event
+       #'(lambda (event)
+	   (declare (ignore event))
+	   (grab-remove window)
+	   (gdk:pointer-ungrab)))
 	
-;; 	(signal-connect window 'motion-notify-event
-;; 	 #'(lambda (event)
-;; 	     (declare (ignore event))
-;; 	     (multiple-value-bind (win xp yp mask)
-;; 		 (gdk:window-get-pointer root-window)
-;; 	       (declare (ignore mask win) (fixnum xp yp))
-;; 	       (widget-set-uposition
-;; 		window :x (- xp x-offset) :y (- yp y-offset)))
-;; 	     t))
-;; 	(signal-connect window 'destroy destroy)))
+      (signal-connect window 'motion-notify-event
+       #'(lambda (event)
+	   (declare (ignore event))
+	   (multiple-value-bind (win xp yp mask) 
+	       (gdk:window-get-pointer root-window)
+	     (declare (ignore mask win) (fixnum xp yp))
+	     (window-move window (- xp x-offset) (- yp y-offset))))))
     
-;;     (widget-show-all window)
-;;     window))
-
-
-;; (let ((modeller nil)
-;;       (sheets nil)
-;;       (rings nil))
-;;   (defun create-shapes ()
-;;     (let ((root-window (gdk:get-root-window)))
-;;       (if (not modeller)
-;; 	  (setq
-;; 	   modeller
-;; 	   (shape-create-icon
-;; 	    "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
-;; 	    #'(lambda () (widget-destroyed modeller))))
-;; 	(widget-destroy modeller))
-
-;;       (if (not sheets)
-;; 	  (setq
-;; 	   sheets
-;; 	   (shape-create-icon
-;; 	    "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
-;; 	    #'(lambda () (widget-destroyed sheets))))
-;; 	(widget-destroy sheets))
-
-;;       (if (not rings)
-;; 	  (setq
-;; 	   rings
-;; 	   (shape-create-icon
-;; 	    "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
-;; 	    #'(lambda () (widget-destroyed rings))))
-;; 	(widget-destroy rings)))))
+    (window-move window x y)
+    (widget-show-all window)
+    window))
+
+
+(let ((modeller nil)
+      (sheets nil)
+      (rings nil))
+  (defun create-shapes ()
+    (let ((root-window (gdk:get-root-window)))
+      (if (not modeller)
+	  (setq
+	   modeller
+	   (create-shape-icon
+	    "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
+	    #'(lambda () (setq modeller nil))))
+	(widget-destroy modeller))
+
+      (if (not sheets)
+	  (setq
+	   sheets
+	   (create-shape-icon
+	    "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
+	    #'(lambda () (setq sheets nil))))
+	(widget-destroy sheets))
+
+      (if (not rings)
+	  (setq
+	   rings
+	   (create-shape-icon
+	    "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
+	    #'(lambda () (setq rings nil))))
+	(widget-destroy rings)))))
 
 
 
@@ -1299,17 +1335,20 @@ (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
 		      :label label :xalign 0.0 :yalign 0.5)
 	      :child (make-instance 'spin-button
 		      :adjustment adjustment :wrap t))))
-      (make-instance 'frame 
-       :label "Not accelerated" :parent main
-       :child (make-instance 'h-box 
-	       :border-width 10
-	       :child-args '(:padding 5)
-	       :child (create-date-spinner "Day : " 
-		       (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
-	       :child (create-date-spinner "Month : " 
-		       (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
-	       :child (create-date-spinner "Year : " 
-		       (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
+      (multiple-value-bind (sec min hour date month year day daylight-p zone)
+	  (get-decoded-time)
+	(declare (ignore sec min hour day daylight-p zone))
+	(make-instance 'frame 
+	 :label "Not accelerated" :parent main
+	 :child (make-instance 'h-box 
+	         :border-width 10
+		 :child-args '(:padding 5)
+		 :child (create-date-spinner "Day : " 
+			 (adjustment-new date 1 31 1 5 0) :out)
+		 :child (create-date-spinner "Month : " 
+		         (adjustment-new month 1 12 1 5 0) :etched-in)
+		 :child (create-date-spinner "Year : " 
+		         (adjustment-new year 0 2100 1 100 0) :in)))))
 
     (let ((spinner1 (make-instance 'spin-button
 		     :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
@@ -1425,102 +1464,166 @@ (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
+     :child label
+     :child (make-instance 'frame
+	     :label "Label Container" :border-width 5
+	     :child(make-instance 'v-box
+		   :children (make-radio-group 'radio-button
+			      '((:label "Resize-Parent" :value :parent :active t)
+				(:label "Resize-Queue" :value :queue)
+				(:label "Resize-Immediate" :value :immediate))
+			      #'(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 (non-zero-p start end)
+ 			 (text-buffer-get-selection-bounds buffer)
+		       (declare (ignore non-zero-p))
+		       (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 (make-instance 'toggle-action 
+			:name "Bold" :stock-id "gtk-bold" :label "Bold" 
+			:accelerator "<control>B" :tooltip "Bold"
+			:callback (create-toggle-callback "Bold"))
+	       :action (make-instance 'toggle-action 
+			:name "Italic" :stock-id "gtk-italic" :label "Italic" 
+			:accelerator "<control>I" :tooltip "Italic"
+			:callback (create-toggle-callback "Italic"))
+	       :action (make-instance 'toggle-action 
+			:name "Underline" :stock-id "gtk-underline" 
+			:label "Underline" :accelerator "<control>U" 
+			:tooltip "Underline"
+			:callback (create-toggle-callback "Underline"))))
+	     (ui (make-instance 'ui-manager
+		  :action-group actions
+		  :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
 
 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
   (make-instance 'v-box
-   :border-width 10 :spacing 10 :parent dialog :show-all t
+   :border-width 10 :spacing 10 :parent dialog
       :children (loop
 	      for n from 1 to 3
 	      collect (make-instance 'toggle-button
@@ -1530,175 +1633,228 @@ (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
 
 ;;; Toolbar test
 
-;; TODO: style properties
-(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
-  (let ((toolbar (make-instance 'toolbar :parent window)))
-;    (setf (toolbar-relief toolbar) :none)
-
-    ;; Insert a stock item
-    (toolbar-append toolbar "gtk-quit"
-     :tooltip-text "Destroy toolbar"
-     :tooltip-private-text "Toolbar/Quit"
-     :callback #'(lambda () (widget-destroy window)))
-
-    ;; Image widge as icon
-    (toolbar-append toolbar "Horizontal"
-     :icon (make-instance 'image :file #p"clg:examples;test.xpm")
-     :tooltip-text "Horizontal toolbar layout"
-     :tooltip-private-text "Toolbar/Horizontal"
-     :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
-
-    ;; Icon from file
-    (toolbar-append toolbar "Vertical"
-     :icon #p"clg:examples;test.xpm"
-     :tooltip-text "Vertical toolbar layout"
-     :tooltip-private-text "Toolbar/Vertical"
-     :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
-
-    (toolbar-append toolbar :space)
-    
-    ;; Stock icon
-    (toolbar-append toolbar "Icons"
-     :icon "gtk-execute"
-     :tooltip-text "Only show toolbar icons"
-     :tooltip-private-text "Toolbar/IconsOnly"
-     :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
-    
-    ;; Icon from pixmap data
-    (toolbar-append toolbar "Text" 
-     :icon gtk-mini-xpm
-     :tooltip-text "Only show toolbar text"
-     :tooltip-private-text "Toolbar/TextOnly"
-     :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
-  
-    (toolbar-append toolbar "Both"
-     :tooltip-text "Show toolbar icons and text"
-     :tooltip-private-text "Toolbar/Both"
-     :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
-
-    (toolbar-append toolbar :space)
-
-    (toolbar-append toolbar (make-instance 'entry)
-     :tooltip-text "This is an unusable GtkEntry"
-     :tooltip-private-text "Hey don't click me!")
-
-    (toolbar-append toolbar :space)
-    
-;;     (toolbar-append-item
-;;      toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Use small spaces"
-;;      :tooltip-private-text "Toolbar/Small"
-;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
-    
-;;     (toolbar-append-item
-;;      toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Use big spaces"
-;;      :tooltip-private-text "Toolbar/Big"
-;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
-    
-;;     (toolbar-append toolbar :space)
-
-    (toolbar-append
-     toolbar "Enable"
-     :tooltip-text "Enable tooltips"
-     :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
-
-    (toolbar-append
-     toolbar "Disable"
-     :tooltip-text "Disable tooltips"
-     :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
+(defun create-toolbar (window)
+  (make-instance 'toolbar 
+   :show-tooltips t :show-arrow nil
+
+   ;; Insert a stock item
+   :child (make-instance 'tool-button 
+	   :stock  "gtk-quit"
+	   :tip-text "Destroy toolbar"
+	   :tip-private "Toolbar/Quit"
+	   :signal (list 'clicked #'(lambda () (widget-destroy window))))
+
+   :child (make-instance 'separator-tool-item)
+
+   :child (make-instance 'tool-button
+	   :label "Horizontal" :stock "gtk-go-forward"
+	   :tip-text "Horizontal toolbar layout"
+	   :tip-private "Toolbar/Horizontal"
+	   :signal (list 'clicked 
+		    #'(lambda (toolbar) 
+			(setf (toolbar-orientation toolbar) :horizontal))
+		    :object :parent))
+
+   :child (make-instance 'tool-button
+	   :label "Vertical" :stock "gtk-go-down"
+	   :tip-text "Vertical toolbar layout"
+	   :tip-private "Toolbar/Vertical"
+	   :signal (list 'clicked 
+		    #'(lambda (toolbar) 
+			(setf (toolbar-orientation toolbar) :vertical))
+		    :object :parent))
+
+   :child (make-instance 'separator-tool-item)
+
+   :children (make-radio-group 'radio-tool-button
+	      '((:label "Icons" :stock "gtk-justify-left"
+		 :tip-text "Only show toolbar icons"
+	         :tip-private "Toolbar/IconsOnly"
+		 :value :icons)
+		(:label "Both" :stock "gtk-justify-center"
+		 :tip-text "Show toolbar icons and text"
+		 :tip-private "Toolbar/Both"
+		 :value :both :active t)
+		(:label "Text" :stock "gtk-justify-right"
+	         :tip-text "Show toolbar text"
+	         :tip-private "Toolbar/TextOnly"
+		 :value :text))
+	      (list
+	       #'(lambda (toolbar style) 
+		   (setf (toolbar-style toolbar) style))
+	       :object :parent))
+
+   :child (make-instance 'separator-tool-item)
+
+   :child (make-instance 'tool-item
+	   :child (make-instance 'entry)
+	   :tip-text "This is an unusable GtkEntry"
+	   :tip-private "Hey don't click me!")
+
+   :child (make-instance 'separator-tool-item)
+
+   :child (make-instance 'tool-button
+	   :label "Enable" :stock "gtk-add"
+	   :tip-text "Enable tooltips"
+	   :tip-private "Toolbar/EnableTooltips"
+	   :signal (list 'clicked 
+		    #'(lambda (toolbar) 
+			(setf (toolbar-show-tooltips-p toolbar) t))
+		    :object :parent))
+
+   :child (make-instance 'tool-button
+	   :label "Disable" :stock "gtk-remove"
+	   :tip-text "Disable tooltips"
+	   :tip-private "Toolbar/DisableTooltips"
+	   :signal (list 'clicked 
+		    #'(lambda (toolbar) 
+			(setf (toolbar-show-tooltips-p toolbar) nil))
+		    :object :parent))
+
+;;    :child (make-instance 'separator-tool-item)
+
+;;    :child (make-instance 'tool-button
+;; 	   :label "GTK" :icon #p"clg:examples;gtk.png"
+;; 	   :tip-text "GTK+ Logo"
+;; 	   :tip-private "Toolbar/GTK+")
+   ))
+
+(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
+  (container-add window (create-toolbar window)))
 
-    (toolbar-append toolbar :space)
 
-;;     (toolbar-append-item
-;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Show borders"
-;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
-    
-;;     (toolbar-append-item
-;;      toolbar
-;;      "Borderless" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Hide borders"
-;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
-
-;;     (toolbar-append toolbar :space)
-
-;;     (toolbar-append-item
-;;      toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Empty spaces"
-;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
-
-;;     (toolbar-append-item
-;;      toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
-;;      :tooltip-text "Lines in spaces"
-;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
-    
-    ))
+;;; Handle box
 
+(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
+  (make-instance 'v-box 
+   :parent window
+   :child (create-label "Above")
+   :child (make-instance 'h-separator)
+   :child (make-instance 'h-box 
+	   :spacing 10
+	   :child (list
+		   (make-instance 'handle-box
+		    :child (create-toolbar window)
+		    :signal (list 'child-attached
+			     #'(lambda (child)
+				 (format t "~A attached~%" child)))
+		    :signal (list 'child-detached
+			     #'(lambda (child)
+				 (format t "~A detached~%" child))))
+		   :expand nil :fill :nil))
+   :child (make-instance 'h-separator)
+   :child (create-label "Below")))
 
 
 ;;; 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))
-
-;; 	(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")))))
+(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
+       :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
+       :child (create-button "button2" "This is button 2. This is also has 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
+     (:toolitem "Logo"))))
+
+(define-toplevel create-ui-manager (window "UI Manager")
+  (let ((ui (make-instance 'ui-manager)))
+    (window-add-accel-group window (ui-manager-accel-group ui))
+    (ui-manager-insert-action-group ui
+     (make-instance 'action-group :name "Actions"
+      :action (make-instance 'action :name "FileMenu" :label "_File")
+      :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
+      :action (make-instance 'action :name "ColorMenu" :label "_Color")
+      :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
+      :action (make-instance 'action :name "HelpMenu" :label "_Help")
+      :action (make-instance 'action 
+	       :name "New" :stock-id "gtk-new" :label "_New" 
+	       :accelerator "<control>N" :tooltip "Create a new file")
+      :action (make-instance 'action 
+	       :name "Open" :stock-id "gtk-open" :label "_Open" 
+	       :accelerator "<control>O" :tooltip "Open a file" 
+	       :callback #'create-file-chooser)
+      :action (make-instance 'action 
+	       :name "Save" :stock-id "gtk-save" :label "_Save" 
+	       :accelerator "<control>S" :tooltip "Save current file")
+      :action (make-instance 'action 
+	       :name "SaveAs" :stock-id "gtk-save" :label "Save _As..." 
+	       :tooltip "Save to a file")
+      :action (make-instance 'action 
+	       :name "Quit" :stock-id "gtk-quit" :label "_Quit" 
+	       :accelerator "<control>Q" :tooltip "Quit" 
+	       :callback (list #'widget-destroy :object window))
+      :action (make-instance 'action 
+	       :name "About" :label "_About" 
+	       :accelerator "<control>A" :tooltip "About")
+      :action (make-instance 'action 
+	       :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
+      :action (make-instance 'toggle-action 
+	       :name "Bold" :stock-id "gtk-bold" :label "_Bold" 
+	       :accelerator "<control>B" :tooltip "Bold" :active t)
+      :actions (make-radio-group 'radio-action
+		'((:name "Red" :value :red :label "_Red" 
+		   :accelerator "<control>R" :tooltip "Blood")
+		  (:name "Green" :value :green :label "_Green" 
+		   :accelerator "<control>G" :tooltip "Grass" :active t)
+		  (:name "Blue" :value :blue :label "_Blue" 
+		   :accelerator "<control>B" :tooltip "Sky"))
+		#'(lambda (active) (print active)))
+      :actions (make-radio-group 'radio-action
+	        '((:name "Square" :value :square :label "_Square" 
+		   :accelerator "<control>S" :tooltip "Square")
+		  (:name "Rectangle" :value :rectangle :label "_Rectangle" 
+		   :accelerator "<control>R" :tooltip "Rectangle")
+		  (:name "Oval" :value :oval :label "_Oval" 
+		   :accelerator "<control>O" :tooltip "Egg"))
+		#'(lambda (active) (print active)))))    
+
+    (ui-manager-add-ui ui *ui-description*)
+
+    (make-instance 'v-box 
+     :parent window
+     :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 Ctrl+Q to quit"
+	     :xalign 0.5 :yalign 0.5
+	     :width-request 200 :height-request 200))))
 		  
 
 
@@ -1714,16 +1870,17 @@ (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)
+ 	    ("font selection" create-font-selection)
+ 	    ("handle box" create-handle-box)
+#+gtk2.6    ("icon view" create-icon-view)
  	    ("image" create-image)
-;; 	    ("item factory")
  	    ("labels" create-labels)
  	    ("layout" create-layout)
  	    ("list" create-list)
@@ -1731,7 +1888,7 @@ (defun create-main-window ()
 ;; 	    ("modal window")
  	    ("notebook" create-notebook)
  	    ("panes" create-panes)
-;; 	    ("progress bar" #|create-progress-bar|#)
+ 	    ("progress bar" create-progress-bar)
  	    ("radio buttons" create-radio-buttons)
  	    ("range controls" create-range-controls)
 ;; 	    ("rc file")
@@ -1739,19 +1896,21 @@ (defun create-main-window ()
  	    ("rulers" create-rulers)
 ;; 	    ("saved position")
  	    ("scrolled windows" create-scrolled-windows)
-;; 	    ("shapes" create-shapes)
+	    ("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)
+ 	    ("toolbar" create-toolbar-window)
+ 	    ("tooltips" create-tooltips)
 ;; 	    ("tree" #|create-tree|#)
+	    ("UI manager" create-ui-manager)
 ))
 	(main-window (make-instance 'window
 		      :title "testgtk.lisp" :name "main_window"
@@ -1766,12 +1925,24 @@ (defun create-main-window ()
 		       :signal (list 'clicked #'widget-destroy 
 				     :object main-window)))) 
 
+    (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
+      (setf 
+       (window-icon main-window) 
+       (gdk:pixbuf-add-alpha icon t 254 254 252)))
+
     ;; Main box
     (make-instance 'v-box
      :parent main-window
      :child-args '(:expand nil)
      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
+     :child (list (make-instance 'label 			  
+		   :label #-cmu(format nil "~A (~A)" 
+			        (lisp-implementation-type)
+				(lisp-implementation-version))
+		          ;; The version string in CMUCL is far too long
+		          #+cmu(lisp-implementation-type))
+		  :fill nil)
      :child (list scrolled-window :expand t)
      :child (make-instance 'h-separator)
      :child (make-instance 'v-box