X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/af5eb9525e79330108906791176a8dc0bea4a3a9..d84a536c6d683251ebfbbc8b760eb095455e275b:/examples/testgtk.lisp

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 2c166d7..c9849f2 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: testgtk.lisp,v 1.12 2004/12/20 00:56:11 espen Exp $
+;; $Id: testgtk.lisp,v 1.14 2004/12/29 21:21:31 espen Exp $
 
 
 ;;; Some of the code in this file are really outdatet, but it is
@@ -183,10 +183,9 @@
    :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
@@ -314,7 +313,7 @@
 (defun cursor-expose (drawing-area event)
   (declare (ignore event))
   (multiple-value-bind (width height)
-      (drawing-area-get-size drawing-area)
+      (widget-get-size-allocation drawing-area)
     (let* ((window (widget-window drawing-area))
 	   (style (widget-style drawing-area))
 	   (white-gc (style-white-gc style))
@@ -466,7 +465,9 @@
   (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))))
 
 
@@ -819,7 +820,9 @@ This one is underlined (こんにちは) in quite a funky fashion"
 	    (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)))
 
 
@@ -856,7 +859,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; 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 
@@ -898,12 +901,12 @@ This one is underlined (こんにちは) in quite a funky fashion"
     (let ((label-box (make-instance 'h-box 
 		      :show-all 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
 		     :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)
@@ -912,24 +915,26 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 (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)
 	       (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))
+ 		 (when curpage
+ 		   (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))
 	
@@ -960,7 +965,6 @@ This one is underlined (こんにちは) in quite a funky fashion"
        :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
@@ -986,7 +990,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
 				   (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"
@@ -1018,64 +1022,40 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;;; 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)))
@@ -1096,7 +1076,29 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; 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 :show-all t
+     :child progress
+     :child activity-mode-button)
+
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when timer (timeout-remove timer))))))
 
 
 ;;; Radio buttons
@@ -1125,7 +1127,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
 (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))
@@ -1623,10 +1625,8 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; 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"
@@ -1741,7 +1741,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
       (make-instance 'v-box
        :parent dialog :border-width 10 :spacing 10 :show-all t
        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
-       :child (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
+       :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
@@ -1843,7 +1843,6 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;; 	    ("font selection")
 ;; 	    ("handle box" create-handle-box)
  	    ("image" create-image)
-;; 	    ("item factory")
  	    ("labels" create-labels)
  	    ("layout" create-layout)
  	    ("list" create-list)
@@ -1851,7 +1850,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;; 	    ("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")
@@ -1888,6 +1887,11 @@ This one is underlined (こんにちは) in quite a funky fashion"
 		       :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