X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/7c1f9a1e515f175feeb4cc0ff7a383f6671935df..8179fd68d4821e35c63190e63804164310259832:/examples/testgtk.lisp

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 2d77b2b..4257fa8 100644
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -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.13 2004/12/26 12:01:10 espen Exp $
+;; $Id: testgtk.lisp,v 1.15 2005/01/06 21:59:51 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))
@@ -821,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)))
 
 
@@ -858,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 
@@ -900,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)
@@ -914,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))
 	
@@ -962,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
@@ -988,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"
@@ -1074,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
@@ -1082,7 +1106,9 @@ This one is underlined (こんにちは) in quite a funky fashion"
 (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)))
+   :children (make-radio-group 'radio-button
+	      '((:label "button1") (:label "button2") (:label "button3"))
+	      nil)))
 
 
 ;;; Rangle controls
@@ -1103,7 +1129,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))
@@ -1448,11 +1474,10 @@ This one is underlined (こんにちは) in quite a funky fashion"
      :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))))))
@@ -1602,107 +1627,90 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;;; Toolbar test
 
 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
-  (let ((toolbar (make-instance 'toolbar :parent window)))
-
-    ;; 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)))
-
-    (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)))
-    
-    ))
+  (make-instance 'toolbar 
+   :show-tooltips t :show-arrow nil :parent window
+
+   ;; 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+")
+   ))
 
 
 
@@ -1826,7 +1834,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")
@@ -1863,7 +1871,10 @@ This one is underlined (こんにちは) in quite a funky fashion"
 		       :signal (list 'clicked #'widget-destroy 
 				     :object main-window)))) 
 
-    (setf (window-icon main-window) #p"clg:examples;gtk.png")
+    (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