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

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 82ee939..b688c16 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -15,11 +15,12 @@
 ;; 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.19 2005-02-26 10:44:11 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))
@@ -29,9 +30,10 @@      (defun ,name ()
 	 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
 	 ,@body)
        
-       (if (not (widget-visible-p ,window))
-	   (widget-show ,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,9 +46,10 @@      (defun ,name ()
 	 (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)
@@ -452,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 ()
@@ -461,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
 
@@ -484,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))
 
 
@@ -1119,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)))))
 
 
 
@@ -1216,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)
@@ -1710,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)
@@ -1729,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)
@@ -1768,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