X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/613fb5703f7af31c08406a99e9440c2a7be33437..bdc1babff5b7fdc80ddaa9baf1b51be64869ad1b:/examples/testgtk.lisp

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 232e92a..aa85e49 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.5 2004-11-08 14:16:12 espen Exp $
+;; $Id: testgtk.lisp,v 1.10 2004-12-05 13:57:10 espen Exp $
 
 
 ;;; Some of the code in this file are really outdatet, but it is
@@ -55,8 +55,8 @@
 
 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
   `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
-    (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
-    ,@body))
+    ,@body
+    (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
 
 
 
@@ -184,9 +184,9 @@
    :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 "OK")
-	   :child (make-instance 'button :label "Cancel")
-	   :child (make-instance 'button :label "Help"))))
+	   :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))))
 
 (define-toplevel create-button-box (window "Button Boxes")
   (make-instance 'v-box
@@ -459,6 +459,16 @@
     (widget-show-all main)))
 
 
+;; Expander
+
+(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
+  (make-instance 'v-box
+   :parent dialog :spacing 5 :border-width 5 :show-all t
+   :child (create-label "Expander demo. Click on the triangle for details.")
+   :child (make-instance 'expander
+	   :label "Details"
+	   :child (create-label "Details can be shown or hidden."))))
+
 
 ;; File chooser dialog
 
@@ -713,100 +723,95 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; List    
     
-;; (define-standard-dialog create-list "List"
-;;   (let ((scrolled-window (scrolled-window-new))
-;;         (list (list-new)))
-;;     (setf (container-border-width scrolled-window) 5)
-;;     (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
-;;     (box-pack-start main-box scrolled-window t t 0)
-;;     (setf (widget-height scrolled-window) 300)
-
-;;     (setf (list-selection-mode list) :extended)
-;;     (scrolled-window-add-with-viewport scrolled-window list)
-;;     (setf
-;;      (container-focus-vadjustment list)
-;;      (scrolled-window-vadjustment scrolled-window))
-;;     (setf
-;;      (container-focus-hadjustment list)
-;;      (scrolled-window-hadjustment scrolled-window))
-    
-;;     (with-open-file (file "clg:examples;gtktypes.lisp")
-;;       (labels ((read-file ()
-;; 	         (let ((line (read-line file nil nil)))
-;; 		   (when line
-;; 		     (container-add list (list-item-new line))
-;; 		     (read-file)))))
-;; 	(read-file)))
-
-;;     (let ((hbox (hbox-new t 5)))
-;;       (setf (container-border-width hbox) 5)
-;;       (box-pack-start main-box hbox nil t 0)
-
-;;       (let ((button (button-new "Insert Row"))
-;; 	    (i 0))
-;; 	(box-pack-start hbox button t t 0)
-;; 	(signal-connect
-;; 	 button 'clicked
-;; 	 #'(lambda ()
-;; 	     (let ((item
-;; 		    (list-item-new (format nil "added item ~A" (incf i)))))
-;; 	       (widget-show item)
-;; 	       (container-add list item)))))
-	
-;;       (let ((button (button-new "Clear List")))
-;; 	(box-pack-start hbox button t t 0)
-;; 	(signal-connect
-;; 	 button 'clicked #'(lambda () (list-clear-items list 0 -1))))
+(define-simple-dialog create-list (dialog "List" :default-height 400)
+  (let* ((store (make-instance 'list-store 
+		 :column-types '(string int boolean)
+		 :column-names '(:foo :bar :baz)
+		 :initial-content '(#("First" 12321 nil)
+				    (:foo "Yeah" :baz t))))
+	 (tree (make-instance 'tree-view :model store)))
 
-;;       (let ((button (button-new "Remove Selection")))
-;; 	(box-pack-start hbox button t t 0)
-;; 	(signal-connect
-;; 	 button 'clicked
-;; 	 #'(lambda ()
-;; 	     (let ((selection (list-selection list)))
-;; 	       (if (eq (list-selection-mode list) :extended)
-;; 		   (let ((item (or
-;; 				(container-focus-child list)
-;; 				(first selection))))
-;; 		     (when item
-;; 		       (let* ((children (container-children list))
-;; 			      (sel-row
-;; 			       (or
-;; 				(find-if
-;; 				 #'(lambda (item)
-;; 				     (eq (widget-state item) :selected))
-;; 				 (member item children))
-;; 				(find-if
-;; 				 #'(lambda (item)
-;; 				     (eq (widget-state item) :selected))
-;; 				 (member item (reverse children))))))
-;; 			 (list-remove-items list selection)
-;; 			 (when sel-row
-;; 			   (list-select-child list sel-row)))))
-;; 		 (list-remove-items list selection)))))
-;; 	(box-pack-start hbox button t t 0)))
-
-;;     (let ((cbox (hbox-new nil 0)))
-;;       (box-pack-start main-box cbox nil t 0)
-
-;;       (let ((hbox (hbox-new nil 5))
-;; 	    (option-menu
-;; 	     (create-option-menu
-;; 	      `(("Single"
-;; 		 ,#'(lambda () (setf (list-selection-mode list) :single)))
-;; 		("Browse"
-;; 		 ,#'(lambda () (setf (list-selection-mode list) :browse)))
-;; 		("Multiple"
-;; 		 ,#'(lambda () (setf (list-selection-mode list) :multiple)))
-;; 		("Extended"
-;; 		 ,#'(lambda () (setf (list-selection-mode list) :extended))))
-;; 	      3)))
-
-;; 	(setf (container-border-width hbox) 5)
-;; 	(box-pack-start cbox hbox t nil 0)
-;; 	(box-pack-start hbox (create-label "Selection Mode :") nil t 0)
-;; 	(box-pack-start hbox option-menu nil t 0)))))
+    (loop
+     with iter = (make-instance 'tree-iter)
+     for i from 1 to 1000
+     do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
+    
+    (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))
+      (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))
+      (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))
+      (tree-view-append-column tree column))      
 
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :child (list
+	     (make-instance 'h-box
+              :spacing 10
+	      :child (make-instance 'button
+		      :label "Remove Selection"
+		      :signal (list 'clicked
+			       #'(lambda ()
+				   (let ((references
+					  (mapcar
+					   #'(lambda (path)
+					       (make-instance 'tree-row-reference :model store :path path))					  
+					   (tree-selection-get-selected-rows
+					    (tree-view-selection tree)))))
+				     (mapc
+				      #'(lambda (reference)
+					  (list-store-remove store reference))
+				      references))))))
+	     :expand nil)
+     :child (list
+	     (make-instance 'h-box
+              :spacing 10
+	      :child (make-instance 'check-button 
+		      :label "Show Headers" :active t
+		      :signal (list 'toggled
+			       #'(lambda (button)
+				   (setf
+				    (tree-view-headers-visible-p tree)
+				    (toggle-button-active-p button)))
+			       :object t))
+	      :child (make-instance 'check-button 
+		      :label "Reorderable" :active nil
+		      :signal (list 'toggled
+			       #'(lambda (button)
+				   (setf
+				    (tree-view-reorderable-p tree)
+				    (toggle-button-active-p button)))
+			       :object t))
+	      :child (list 
+		      (make-instance 'h-box
+                       :child (make-instance 'label :label "Selection Mode: ")
+		       :child (make-instance 'combo-box
+			       :content '("Single" "Browse" "Multiple") 
+			       :active 0
+			       :signal (list 'changed
+				        #'(lambda (combo-box)
+					    (setf 
+					     (tree-selection-mode 
+					      (tree-view-selection tree))
+					     (svref 
+					      #(:single :browse :multiple)
+					      (combo-box-active combo-box))))
+					:object t)))
+		      :expand nil))
+	     :expand nil)
+     :child (make-instance 'scrolled-window 
+	    :child tree :hscrollbar-policy :automatic))))
 
 
 ;; Menus
@@ -1430,96 +1435,79 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; Idle test
 
-;; (define-standard-dialog create-idle-test "Idle Test"
-;;   (let* ((container (make-instance 'hbox :parent main-box))
-;; 	 (label (make-instance 'label
-;; 		 :label "count: 0" :xpad 10 :ypad 10 :parent container))
-;; 	 (idle nil)
-;; 	 (count 0))
-;;     (declare (fixnum count))
-;;     (signal-connect
-;;      window 'destroy #'(lambda () (when idle (idle-remove idle))))
+(define-simple-dialog create-idle-test (dialog "Idle Test")
+  (let ((label (make-instance 'label
+		:label "count: 0" :xpad 10 :ypad 10))
+	(idle nil)
+	(count 0))
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when idle (idle-remove idle))))
  
-;;     (make-instance 'frame
-;;      :label "Label Container" :border-width 5 :parent main-box
-;;      :child
-;;      (make-instance 'v-box
-;;       :children
-;;       (create-radio-button-group
-;;        '(("Resize-Parent" :parent)
-;; 	 ("Resize-Queue" :queue)
-;; 	 ("Resize-Immediate" :immediate))
-;;        0
-;;        '(setf container-resize-mode) container)))
-
-;;     (make-instance 'button
-;;      :label "start" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (unless idle
-;; 	     (setq
-;; 	      idle
-;; 	      (idle-add
-;; 	       #'(lambda ()
-;; 		   (incf count)
-;; 		   (setf (label-label label) (format nil "count: ~D" count))
-;; 		   t))))))))
+    (make-instance 'v-box
+     :parent dialog :border-width 10 :spacing 10 :show-all t
+     :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
+			      #'(lambda (mode)
+ 				  (setf 
+ 				   (container-resize-mode (dialog-action-area dialog)) mode))))))
+
+    (dialog-add-button dialog "Start"
+     #'(lambda ()
+	 (unless idle
+	   (setq idle
+	    (idle-add
+	     #'(lambda ()
+		 (incf count)
+		 (setf (label-label label) (format nil "count: ~D" count))
+		 t))))))
       
-;;     (make-instance 'button
-;;      :label "stop" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (when idle
-;; 	     (idle-remove idle)
-;; 	     (setq idle nil))))))))
+    (dialog-add-button dialog "Stop"
+     #'(lambda ()
+	 (when idle
+	   (idle-remove idle)
+	   (setq idle nil))))))
     
 
 
 ;;; Timeout test
 
-;; (define-standard-dialog create-timeout-test "Timeout Test"
-;;   (let ((label (make-instance 'label
-;; 		:label "count: 0" :xpad 10 :ypad 10 :parent main-box))
-;; 	(timer nil)
-;; 	(count 0))
-;;     (declare (fixnum count))
-;;     (signal-connect
-;;      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
-          
-;;     (make-instance 'button
-;;      :label "start" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (unless timer
-;; 	     (setq
-;; 	      timer
-;; 	      (timeout-add
-;; 	       100
-;; 	       #'(lambda ()
-;; 		   (incf count)
-;; 		   (setf (label-label label) (format nil "count: ~D" count))
-;; 		   t))))))))
-
-;;     (make-instance 'button
-;;      :label "stop" :can-default t :parent action-area
-;;      :signals
-;;      (list
-;;       (list
-;;        'clicked
-;;        #'(lambda ()
-;; 	   (when timer
-;; 	     (timeout-remove timer)
-;; 	     (setq timer nil))))))))
-  
+(define-simple-dialog create-timeout-test (dialog "Timeout Test")
+  (let ((label (make-instance 'label
+		:label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
+	(timer nil)
+	(count 0))
+    (signal-connect dialog 'destroy 
+     #'(lambda () (when timer (timeout-remove timer))))
+
+    (dialog-add-button dialog "Start"
+     #'(lambda ()
+	 (unless timer
+	   (setq timer
+	    (timeout-add 100
+	     #'(lambda ()
+		 (incf count)
+		 (setf (label-label label) (format nil "count: ~D" count))
+		 t))))))
+
+    (dialog-add-button dialog "Stop"
+     #'(lambda ()
+	 (when timer
+	   (timeout-remove timer)
+	   (setq timer nil))))))
+
+
+;;; Text
+
+(define-simple-dialog create-text (dialog "Text" :default-width 400
+					         :default-height 400)
+  (make-instance 'text-view :border-width 10  :parent dialog :visible t))  
 
 ;;; Toggle buttons
 
@@ -1644,66 +1632,96 @@ This one is underlined (こんにちは) in quite a funky fashion"
 
 ;;; Tooltips test
 
-;; (define-standard-dialog create-tooltips "Tooltips"
-;;   (setf
-;;    (window-allow-grow-p window) t
-;;    (window-allow-shrink-p window) nil
-;;    (window-auto-shrink-p window) t
-;;    (widget-width window) 200
-;;    (container-border-width main-box) 10
-;;    (box-spacing main-box) 10)
-
-;;   (let ((tooltips (tooltips-new)))
-;;     (flet ((create-button (label tip-text tip-private)
-;; 	     (let ((button (make-instance 'toggle-button
-;; 		    :label label :parent main-box)))
-;; 	       (tooltips-set-tip tooltips button tip-text tip-private)
-;; 	       button)))
-;;       (create-button "button1" "This is button 1" "ContextHelp/button/1")
-;;       (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")
-
-;;       (let* ((toggle (create-button "Override TipSQuery Label"
-;; 				    "Toggle TipsQuery view" "Hi msw! ;)"))
-;; 	     (box (make-instance 'v-box
-;; 		   :homogeneous nil :spacing 5 :border-width 5
-;; 		   :parent (make-instance 'frame
-;; 	                    :label "ToolTips Inspector"
-;; 			    :label-xalign 0.5 :border-width 0
-;; 			    :parent main-box)))
-;; 	     (button (make-instance 'button :label "[?]" :parent box))
-;; 	     (tips-query (make-instance 'tips-query
-;; 			  :caller button :parent box)))
-
-;; 	(signal-connect
-;; 	 button 'clicked #'tips-query-start-query :object tips-query)
-	
-;; 	(signal-connect
-;; 	 tips-query 'widget-entered
-;; 	 #'(lambda (widget tip-text tip-private)
-;; 	     (declare (ignore widget tip-private))
-;; 	     (when (toggle-button-active-p toggle)
-;; 	       (setf
-;; 		(label-label tips-query)
-;; 		(if tip-text
-;; 		    "There is a Tip!"
-;; 		  "There is no Tip!"))
-;; 	       (signal-emit-stop tips-query 'widget-entered))))
-	
-;; 	(signal-connect
-;; 	 tips-query 'widget-selected
-;; 	 #'(lambda (widget tip-text tip-private event)
-;; 	     (declare (ignore tip-text event))
-;; 	     (when widget
-;; 	       (format
-;; 		t "Help ~S requested for ~S~%"
-;; 		(or tip-private "None") (type-of widget)))
-;; 	     t))
+(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
+  (let ((tooltips (make-instance 'tooltips)))
+    (flet ((create-button (label tip-text tip-private)
+	     (let ((button (make-instance 'toggle-button :label label)))
+	       (tooltips-set-tip tooltips button tip-text tip-private)
+	       button)))
+      (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")))
+
+    (let ((close-button (first (container-children (dialog-action-area dialog)))))
+    (tooltips-set-tip tooltips close-button "Push this button to close window"
+ 	 "ContextHelp/buttons/Close"))))
+
+
+;;; UI Manager
+
+(defvar *ui-description*
+  '((:menubar "MenuBar"
+     (:menu "FileMenu"
+      (:menuitem "New")
+      (:menuitem "Open")
+      (:menuitem "Save")
+      (:menuitem "SaveAs")
+      :separator
+      (:menuitem "Quit"))
+     (:menu "PreferencesMenu"
+       (:menu "ColorMenu"
+	(:menuitem "Red")
+ 	(:menuitem "Green")
+ 	(:menuitem "Blue"))
+       (:menu "ShapeMenu"
+        (:menuitem "Square")
+        (:menuitem "Rectangle")
+        (:menuitem "Oval"))
+       (:menuitem "Bold"))
+     (:menu "HelpMenu"
+      (:menuitem "About")))
+    (:toolbar "ToolBar"
+     (:toolitem "Open")
+     (:toolitem "Quit")
+     (:separator "Sep1")
+     (:toolitem "Logo"))))
+
+(define-simple-dialog create-ui-manager (dialog "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")
+	  :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")
+	  :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)
+    (ui-manager-add-ui ui *ui-description*)
 
-;; 	(tooltips-set-tip
-;; 	 tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
-;; 	(tooltips-set-tip
-;; 	 tooltips close-button "Push this button to close window"
-;; 	 "ContextHelp/buttons/Close")))))
+    (window-add-accel-group dialog (ui-manager-accel-group ui))
+    
+    (make-instance 'v-box 
+     :parent dialog :show-all t
+     :child (list 
+	     (ui-manager-get-widget ui "/MenuBar")
+	     :expand nil :fill nil)
+     :child (list 
+	     (ui-manager-get-widget ui "/ToolBar")
+	     :expand nil :fill nil)
+     :child (make-instance 'label
+	     :label "Type <alt> to start" 
+	     :xalign 0.5 :yalign 0.5
+	     :width-request 200 :height-request 200))))
 		  
 
 
@@ -1718,14 +1736,13 @@ This one is underlined (こんにちは) in quite a funky fashion"
  	    ("buttons" create-buttons)
  	    ("calendar" create-calendar)
  	    ("check buttons" create-check-buttons)
-;; 	    ("clist" #|create-clist|#)
  	    ("color selection" create-color-selection)
-;; 	    ("ctree" #|create-ctree|#)
 ;; 	    ("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)
@@ -1733,7 +1750,7 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;; 	    ("item factory")
  	    ("labels" create-labels)
  	    ("layout" create-layout)
-;; 	    ("list" create-list)
+ 	    ("list" create-list)
 	    ("menus" create-menus)
 ;; 	    ("modal window")
  	    ("notebook" create-notebook)
@@ -1749,16 +1766,17 @@ This one is underlined (こんにちは) in quite a funky fashion"
 ;; 	    ("shapes" create-shapes)
  	    ("spinbutton" create-spins)
  	    ("statusbar" create-statusbar)
-;; 	    ("test idle" create-idle-test)
+ 	    ("test idle" create-idle-test)
 ;; 	    ("test mainloop")
 ;; 	    ("test scrolling")
 ;; 	    ("test selection")
-;; 	    ("test timeout" create-timeout-test)
-;; 	    ("text" #|create-text|#)
+ 	    ("test timeout" create-timeout-test)
+ 	    ("text" create-text)
  	    ("toggle buttons" create-toggle-buttons)
  	    ("toolbar" create-toolbar)
-;; 	    ("tooltips" create-tooltips)
+ 	    ("tooltips" create-tooltips)
 ;; 	    ("tree" #|create-tree|#)
+	    ("UI manager" create-ui-manager)
 ))
 	(main-window (make-instance 'window
 		      :title "testgtk.lisp" :name "main_window"