X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/33f468b7e5546dfc5ab5db9af8523562314b4931..7c14f6abb37972445ffc0be122d743da59ea9063:/examples/testgtk.lisp

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 69af8e1..a8feb8b 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-2006 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.11 2004-12-17 00:45:00 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.39 2007-06-19 12:49:18 espen Exp $
 
+#+sbcl(require :gtk)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
 
-;(use-package "GTK")
-(in-package "GTK")
+(defpackage "TESTGTK"
+  (:use "COMMON-LISP" "CLG"))
+
+(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,13 +56,14 @@ (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)
@@ -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 "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))))
+	   :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
@@ -239,15 +251,14 @@ (define-simple-dialog create-buttons (dialog "Buttons")
 				  (widget-hide button+1)
 				(widget-show button+1))))
 	  (table-attach table button column (1+ column) row (1+ row)
-			:options '(:expand :fill)))))
-    (widget-show-all table)))
+			: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)))
 
 
@@ -255,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
@@ -267,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 ()
@@ -297,97 +305,86 @@ (define-dialog create-color-selection (dialog "Color selection dialog"
     (signal-connect dialog :cancel #'widget-destroy :object t)))
 
 
-;;; Cursors
+;;; Cursors (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
 
 (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
+	 (gffi:int-enum
+	  (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
+	  'gdk:cursor-type)))
+    (setf (label-label label) (string-downcase cursor))
+    (widget-set-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- (gffi: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))
 
-;; (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)))
-    
+    (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)))
 
-; (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
@@ -456,15 +453,14 @@ (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 :show-all t
+   :parent dialog :spacing 5 :border-width 5
    :child (create-label "Expander demo. Click on the triangle for details.")
    :child (make-instance 'expander
 	   :label "Details"
@@ -474,143 +470,171 @@ (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
 ;; 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
+
+#+(or cmu sbcl)
+(defun get-directory-listing (directory)
+  (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
+	 collect (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 filename directory-p)))
+      #+cmu(unix:close-dir dir)
+      #+sbcl(sb-posix:closedir dir))))
+
+#+clisp
+(defun get-directory-listing (directory)
+  (nconc
+   (mapcar #'(lambda (entry)
+	       (let ((pathname (namestring (first entry))))
+		 (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
+    (directory (format nil "~A*" directory) :full t))
+   (mapcar #'(lambda (entry)
+	       (let ((pathname (namestring entry)))
+		 (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
+
+    (directory (format nil "~A*/" directory)))))
+
+
+#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+(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)    
+    (loop
+     for (filename directory-p) in (get-directory-listing directory)
+     unless (or (string= filename ".") (string= filename ".."))
+     do (list-store-insert store 0
+	 (vector
+	  filename 
+	  (if directory-p folder-pixbuf file-pixbuf)
+	  directory-p))))
+
+  (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))
 
 
@@ -618,16 +642,14 @@ (define-toplevel create-image (window "Image")
       
 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
   (flet ((create-label-in-frame (frame-label label-text &rest args)
-	   (list 
-	    (make-instance 'frame
-	     :label frame-label
-	     :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
-	    :fill nil :expand nil)))
+	   (make-instance 'frame
+	    :label frame-label
+	    :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
     (make-instance 'h-box
      :spacing 5 :parent window
      :child-args '(:fill nil :expand nil)
      :child (make-instance 'v-box
-             :spacing 5
+             :spacing 5 :child-args '(:fill nil :expand nil)
 	     :child (create-label-in-frame "Normal Label" "This is a Normal label")
 	     :child (create-label-in-frame "Multi-line Label"
 "This is a Multi-line label.
@@ -644,7 +666,7 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 Third line"
                      :justify :right))
      :child (make-instance 'v-box
-	     :spacing 5
+	     :spacing 5 :child-args '(:fill nil :expand nil)
 	     :child (create-label-in-frame "Line wrapped label"
 "This is an example of a line-wrapped label.  It should not be taking up the entire             width allocated to it, but automatically wraps the words to fit.  The time has come, for all good men, to come to the aid of their party.  The sixth sheik's six sheep's sick.
      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
@@ -658,46 +680,40 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 
 	     :child (create-label-in-frame "Underlined label"
 "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)
-
+;;; Layout (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
+
+(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
@@ -707,18 +723,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))))))
 
 
 
@@ -726,7 +746,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))))
@@ -740,23 +760,23 @@ (define-simple-dialog create-list (dialog "List" :default-height 400)
     (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))
+      (cell-layout-add-attribute column cell 'text (tree-model-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))
+      (cell-layout-add-attribute column cell 'text (tree-model-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))
+      (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
       (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
@@ -829,14 +849,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)))
 
 
@@ -844,7 +866,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"))))
@@ -873,7 +895,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 
@@ -912,41 +934,42 @@ (defun create-notebook-page (notebook page-num)
 	     :label "Hide page"
 	     :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)
       (notebook-append notebook page label-box menu-box))))
 	
-
 (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))
 	
@@ -977,7 +1000,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
@@ -1003,7 +1025,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"
@@ -1015,13 +1037,13 @@ (define-simple-dialog create-notebook (dialog "Notebook")
        :spacing 5 :border-width 10
        :parent (list main :expand nil)
        :child (make-instance 'button 
-	       :label "prev"
+	       :label "Prev"
 	       :signal (list 'clicked #'notebook-prev-page :object notebook))
        :child (make-instance 'button 
-	       :label "next"
+	       :label "Next"
 	       :signal (list 'clicked #'notebook-next-page :object notebook))
        :child (make-instance 'button 
-	       :label "rotate"
+	       :label "Rotate"
 	       :signal (let ((tab-pos 0))
 			 (list 'clicked 
 			  #'(lambda ()
@@ -1032,67 +1054,44 @@ (define-simple-dialog create-notebook (dialog "Notebook")
     (widget-show-all main)))
 
 
+
 ;;; 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)))
-
+  (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 :options '(:expand :fill))
-      (signal-connect
-       check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
-    (let ((check-button (make-instance 'check-button :label "Shrink")))
+      (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))
-      (setf (toggle-button-active-p check-button) t)
-      (signal-connect
-       check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
+      (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")))
+    (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
       (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")))
+      (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))
-      (setf (toggle-button-active-p check-button) t)
-      (signal-connect
-       check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
-    frame))
+      (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)))
@@ -1113,15 +1112,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
@@ -1129,7 +1152,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)
@@ -1142,7 +1165,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))
@@ -1164,13 +1187,7 @@ (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))
-
+  				: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
@@ -1233,7 +1250,7 @@ (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
 	       (make-instance 'frame :label label :child table))))
 
       (make-instance 'v-box
-       :parent dialog :border-width 5 :spacing 5 :show-all t
+       :parent dialog :border-width 5 :spacing 5
        :child (create-frame "Color Options"
 	       '(("Foreground" "Red" "Green" "Blue")
 		 ("Background" "Red" "Green" "Blue")))
@@ -1250,86 +1267,79 @@ (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
 
 ;;; 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)))))
 
 
 
@@ -1347,17 +1357,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)
@@ -1482,16 +1495,15 @@ (define-simple-dialog create-idle-test (dialog "Idle Test")
      #'(lambda () (when idle (idle-remove idle))))
  
     (make-instance 'v-box
-     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :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 (create-radio-button-group
-			      '(("Resize-Parent" :parent)
-				("Resize-Queue" :queue)
-				("Resize-Immediate" :immediate))
-			      0
+		   :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))))))
@@ -1563,31 +1575,34 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400
 		     (if active 
 			 (push tag active-tags)
 		       (setq active-tags (delete tag active-tags)))
-		     (multiple-value-bind (start end)
-			 (text-buffer-get-selection-bounds buffer)
+ 		     (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 (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"))))
+	       :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
@@ -1623,14 +1638,41 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400
 	 :after t)
 	
 	(container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
-	(container-add dialog text-view)))))
+	(container-add dialog text-view) 
+
+	(let ((position (make-instance 'label :visible t)))
+	  (flet ((update-position (line column)
+		   (setf 
+		    (label-label position)
+		    (format nil "Cursor Position: ~d,~d" (1+ line) column))))
+	    (update-position 0 0)
+
+	    ;; Callback to display current position when cursor is moved
+	    (signal-connect buffer 'mark-set
+	     #'(lambda (iter mark)
+		 (when (and 
+			(slot-boundp mark 'name) 
+			(string= (text-mark-name mark) "insert"))
+		   (update-position 
+		    (text-iter-line iter) (text-iter-line-offset iter)))))
+
+ 	    ;; Callback to display current position after the
+ 	    ;; buffer has been modified
+	    (signal-connect buffer 'changed
+	     #'(lambda ()
+		 (let ((iter (text-buffer-get-iter-at-insert buffer)))
+		   (update-position 
+		    (text-iter-line iter) (text-iter-line-offset iter))))
+	     :after t))
+
+	  (container-add dialog position :expand nil))))))
 
 
 ;;; 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
@@ -1640,111 +1682,117 @@ (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
@@ -1756,9 +1804,9 @@ (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
 	       (tooltips-set-tip tooltips button tip-text tip-private)
 	       button)))
       (make-instance 'v-box
-       :parent dialog :border-width 10 :spacing 10 :show-all t
+       :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 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")))))
+       :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
@@ -1787,44 +1835,65 @@ (defvar *ui-description*
     (:toolbar "ToolBar"
      (:toolitem "Open")
      (:toolitem "Quit")
-     (:separator "Sep1")
+     :separator
      (: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)
+  (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*)
 
-    (window-add-accel-group window (ui-manager-accel-group ui))
-    
     (make-instance 'v-box 
-     :parent window :show-all t
+     :parent window
      :child (list 
 	     (ui-manager-get-widget ui "/MenuBar")
 	     :expand nil :fill nil)
@@ -1832,7 +1901,7 @@ (define-toplevel create-ui-manager (window "UI Manager")
 	     (ui-manager-get-widget ui "/ToolBar")
 	     :expand nil :fill nil)
      :child (make-instance 'label
-	     :label "Type <alt> to start" 
+	     :label "Type Ctrl+Q to quit"
 	     :xalign 0.5 :yalign 0.5
 	     :width-request 200 :height-request 200))))
 		  
@@ -1841,26 +1910,22 @@ (define-toplevel create-ui-manager (window "UI Manager")
 ;;; Main window
       
 (defun create-main-window ()
-;;   (rc-parse "clg:examples;testgtkrc2")
-;;   (rc-parse "clg:examples;testgtkrc")
-
   (let* ((button-specs
 	  '(("button box" create-button-box)
  	    ("buttons" create-buttons)
  	    ("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)
+	    #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+	    ("icon view" create-icon-view)
  	    ("image" create-image)
-;; 	    ("item factory")
  	    ("labels" create-labels)
  	    ("layout" create-layout)
  	    ("list" create-list)
@@ -1868,7 +1933,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")
@@ -1877,40 +1942,52 @@ (defun create-main-window ()
 ;; 	    ("saved position")
  	    ("scrolled windows" create-scrolled-windows)
 	    ("size group" create-size-group)
-;; 	    ("shapes" create-shapes)
+ 	    ("shapes" create-shapes)
  	    ("spinbutton" create-spins)
  	    ("statusbar" create-statusbar)
  	    ("test idle" create-idle-test)
-;; 	    ("test mainloop")
-;; 	    ("test scrolling")
-;; 	    ("test selection")
  	    ("test timeout" create-timeout-test)
  	    ("text" create-text)
  	    ("toggle buttons" create-toggle-buttons)
- 	    ("toolbar" create-toolbar)
+ 	    ("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"
-		      :default-width 200 :default-height 400
-		      :allow-grow t :allow-shrink nil))
-	(scrolled-window (make-instance 'scrolled-window
-	                  :hscrollbar-policy :automatic 
-			  :vscrollbar-policy :automatic
-			  :border-width 10))
-	(close-button (make-instance 'button 
-		       :label "close" :can-default t
-		       :signal (list 'clicked #'widget-destroy 
-				     :object main-window)))) 
+	    ("UI manager" create-ui-manager)))
+
+	 (main-window (make-instance 'window
+		       :title "testgtk.lisp" :name "main_window"
+		       :default-width 200 :default-height 400
+		       :allow-grow t :allow-shrink nil))
+	 (scrolled-window (make-instance 'scrolled-window
+	                   :hscrollbar-policy :automatic 
+			   :vscrollbar-policy :automatic
+			   :border-width 10))
+	 (close-button (make-instance 'button 
+		        :stock "gtk-close" :can-default t
+		        :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 (clg-version)) :fill nil)
+     :child (list (make-instance 'label 			  
+		   :label #-cmu
+		          (format nil "~A (~A)" 
+			   (lisp-implementation-type)
+			   #-clisp
+			   (lisp-implementation-version)
+			   #+clisp
+			   (let ((version (lisp-implementation-version)))
+			     (subseq version 0 (position #\sp 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 
@@ -1920,9 +1997,9 @@ (defun create-main-window ()
     (let ((content-box 
 	   (make-instance 'v-box
 	    :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
-	    :children (mapcar #'(lambda (spec) 
+	    :children (mapcar #'(lambda (spec)
 				  (apply #'create-button spec))
-			      button-specs))))
+		       button-specs))))
       (scrolled-window-add-with-viewport scrolled-window content-box))
     
     (widget-grab-focus close-button)
@@ -1930,4 +2007,4 @@ (defun create-main-window ()
     main-window))
  
 (clg-init)
-(create-main-window)
+(within-main-loop (create-main-window))