X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/842e5ffe2acf8474415544a32657c5948d72a2c4..73383a9efec7360f61b9ef544fdba3db61b2dd10:/examples/testgtk.lisp?ds=sidebyside

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 7fe0786..b688c16 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -15,23 +15,25 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: testgtk.lisp,v 1.16 2005-01-12 14:03:04 espen Exp $
+;; $Id: testgtk.lisp,v 1.25 2005-03-13 18:16:08 espen Exp $
 
+(defpackage "TESTGTK"
+  (:use "COMMON-LISP" "GTK"))
 
-;(use-package "GTK")
-(in-package "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)
@@ -40,13 +42,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)
@@ -185,7 +188,7 @@ (defun create-bbox-in-frame (class frame-label spacing width height layout)
 
 (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
@@ -234,15 +237,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)))
 
 
@@ -250,7 +252,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
@@ -262,25 +264,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 ()
@@ -331,7 +330,7 @@ (define-simple-dialog create-cursors (dialog "Cursors")
 			       2 10 0)))
 	(drawing-area (make-instance 'drawing-area
 		       :width-request 80 :height-request 80
-		       :events '(:exposure-mask :button-press-mask)))
+		       :events '(:exposure :button-press)))
 	(label (make-instance 'label :label "XXX")))
 
     (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
@@ -339,15 +338,15 @@ (define-simple-dialog create-cursors (dialog "Cursors")
     (signal-connect drawing-area 'button-press-event
      #'(lambda (event)
 	 (case (gdk:event-button event)
-	   (1 (spin-button-spin spinner :step-forward 0.0))
-	   (3 (spin-button-spin spinner :step-backward 0.0)))
+	   (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 0.0))
-	   (:down (spin-button-spin spinner :step-backward 0.0)))
+	   (:up (spin-button-spin spinner :step-forward))
+	   (:down (spin-button-spin spinner :step-backward)))
 	 t))
 
     (signal-connect spinner 'changed
@@ -355,7 +354,7 @@ (define-simple-dialog create-cursors (dialog "Cursors")
 	 (set-cursor spinner drawing-area label)))
 
     (make-instance 'v-box
-     :parent dialog :border-width 10 :spacing 5 :show-all t
+     :parent dialog :border-width 10 :spacing 5
      :child (list
 	     (make-instance 'h-box
 	      :border-width 5
@@ -365,7 +364,6 @@ (define-simple-dialog create-cursors (dialog "Cursors")
 	      :child spinner)
 	     :expand nil)
      :child (make-instance 'frame
-;	     :shadow-type :etched-in
 	     :label "Cursor Area" :label-xalign 0.5 :border-width 10
 	     :child drawing-area)
      :child (list label :expand nil))
@@ -440,15 +438,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"
@@ -458,6 +455,12 @@ (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 ()
@@ -467,6 +470,15 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
        (widget-destroy dialog))))
 
 
+;; 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")))
+
 
 ;;; Handle box
 
@@ -490,9 +502,125 @@ (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
    :child (make-instance 'h-separator)
    :child (create-label "Below")))
 
+
+;;; 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)))
+      
+	(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))
 
 
@@ -571,9 +699,8 @@ (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
@@ -583,18 +710,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))))))
 
 
 
@@ -632,7 +763,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
@@ -791,12 +922,12 @@ (defun create-notebook-page (notebook page-num book-closed)
 	     :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 :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 :pixbuf book-closed)
 		     :child (make-instance 'label :label title))))
@@ -984,7 +1115,7 @@ (define-simple-dialog create-progress-bar (dialog "Progress Bar")
 		     t))))
 
     (make-instance 'v-box
-     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :parent dialog :border-width 10 :spacing 10
      :child progress
      :child activity-mode-button)
 
@@ -996,7 +1127,7 @@ (define-simple-dialog create-progress-bar (dialog "Progress Bar")
 
 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
   (make-instance 'v-box
-   :parent dialog :border-width 10 :spacing 10 :show-all t
+   :parent dialog :border-width 10 :spacing 10
    :children (make-radio-group 'radio-button
 	      '((:label "button1") (:label "button2") (:label "button3"))
 	      nil)))
@@ -1007,7 +1138,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)
@@ -1042,13 +1173,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
@@ -1111,7 +1236,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")))
@@ -1128,86 +1253,78 @@ (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 :time event))))
+
+      (signal-connect window 'button-release-event
+       #'(lambda (event)
+	   (grab-remove window)
+	   (gdk:pointer-ungrab event)))
 	
-;; 	(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)))))
 
 
 
@@ -1225,17 +1342,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)
@@ -1360,7 +1480,7 @@ (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
@@ -1442,6 +1562,7 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400
 		       (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))))))))
@@ -1507,7 +1628,7 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400
 
 (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
@@ -1617,7 +1738,7 @@ (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 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")))))
 
@@ -1685,7 +1806,7 @@ (define-toplevel create-ui-manager (window "UI Manager")
     (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)
@@ -1718,8 +1839,9 @@ (defun create-main-window ()
 ;; 	    ("event watcher")
  	    ("enxpander" create-expander)
  	    ("file chooser" create-file-chooser)
-;; 	    ("font selection")
+ 	    ("font selection" create-font-selection)
  	    ("handle box" create-handle-box)
+#+gtk2.6    ("icon view" create-icon-view)
  	    ("image" create-image)
  	    ("labels" create-labels)
  	    ("layout" create-layout)
@@ -1737,7 +1859,7 @@ (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)
@@ -1776,6 +1898,13 @@ (defun create-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