X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/977a550ddb36c087c5bf35fab8dfd5c286d79cb6..3cfa455c49f16f4548b9f7fc20009f3252fa0c3f:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 55e6c78..7fe0786 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 +;; Copyright (C) 1999-2005 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,11 +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.14 2004-12-29 21:21:31 espen Exp $ - - -;;; Some of the code in this file are really outdatet, but it is -;;; still the most complete example of how to use the library +;; $Id: testgtk.lisp,v 1.16 2005-01-12 14:03:04 espen Exp $ ;(use-package "GTK") @@ -465,7 +461,7 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t) (dialog-add-button dialog "gtk-ok" #'(lambda () - (if (slot-boundp dialog 'filename) + (if (slot-boundp dialog 'filename) (format t "Selected file: ~A~%" (file-chooser-filename dialog)) (write-line "No files selected")) (widget-destroy dialog)))) @@ -474,129 +470,25 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) ;;; Handle box -;; (defun create-handle-box-toolbar () -;; (let ((toolbar (toolbar-new :horizontal :both))) -;; (toolbar-append-item -;; toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Horizontal toolbar layout" -;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal))) - -;; (toolbar-append-item -;; toolbar "Vertical" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Vertical toolbar layout" -;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical))) - -;; (toolbar-append-space toolbar) - -;; (toolbar-append-item -;; toolbar "Icons" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Only show toolbar icons" -;; :callback #'(lambda () (setf (toolbar-style toolbar) :icons))) - -;; (toolbar-append-item -;; toolbar "Text" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Only show toolbar text" -;; :callback #'(lambda () (setf (toolbar-style toolbar) :text))) - -;; (toolbar-append-item -;; toolbar "Both" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Show toolbar icons and text" -;; :callback #'(lambda () (setf (toolbar-style toolbar) :both))) - -;; (toolbar-append-space toolbar) - -;; (toolbar-append-item -;; toolbar "Small" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Use small spaces" -;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5))) - -;; (toolbar-append-item -;; toolbar "Big" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Use big spaces" -;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10))) - -;; (toolbar-append-space toolbar) - -;; (toolbar-append-item -;; toolbar "Enable" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Enable tooltips" -;; :callback #'(lambda () (toolbar-enable-tooltips toolbar))) - -;; (toolbar-append-item -;; toolbar "Disable" (pixmap-new "clg:examples;test.xpm") -;; :tooltip-text "Disable tooltips" -;; :callback #'(lambda () (toolbar-disable-tooltips toolbar))) - -;; (toolbar-append-space toolbar) - -;; (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)) - - -;; (defun handle-box-child-signal (handle-box child action) -;; (format t "~S: child ~S ~A~%" handle-box child action)) - - -;; (define-test-window create-handle-box "Handle Box Test" -;; (setf (window-allow-grow-p window) t) -;; (setf (window-allow-shrink-p window) t) -;; (setf (window-auto-shrink-p window) nil) -;; (setf (container-border-width window) 20) -;; (let ((v-box (v-box-new nil 0))) -;; (container-add window v-box) - -;; (container-add v-box (create-label "Above")) -;; (container-add v-box (hseparator-new)) - -;; (let ((hbox (hbox-new nil 10))) -;; (container-add v-box hbox) - -;; (let ((handle-box (handle-box-new))) -;; (box-pack-start hbox handle-box nil nil 0) -;; (signal-connect -;; handle-box 'child-attached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "attached"))) -;; (signal-connect -;; handle-box 'child-detached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "detached"))) -;; (container-add handle-box (create-handle-box-toolbar))) - -;; (let ((handle-box (handle-box-new))) -;; (box-pack-start hbox handle-box nil nil 0) -;; (signal-connect -;; handle-box 'child-attached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "attached"))) -;; (signal-connect -;; handle-box 'child-detached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "detached"))) - -;; (let ((handle-box2 (handle-box-new))) -;; (container-add handle-box handle-box2) -;; (signal-connect -;; handle-box2 'child-attached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "attached"))) -;; (signal-connect -;; handle-box2 'child-detached -;; #'(lambda (child) -;; (handle-box-child-signal handle-box child "detached"))) -;; (container-add handle-box2 (create-label "Foo!"))))) - -;; (container-add v-box (hseparator-new)) -;; (container-add v-box (create-label "Below")))) +(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20) + (make-instance 'v-box + :parent window + :child (create-label "Above") + :child (make-instance 'h-separator) + :child (make-instance 'h-box + :spacing 10 + :child (list + (make-instance 'handle-box + :child (create-toolbar window) + :signal (list 'child-attached + #'(lambda (child) + (format t "~A attached~%" child))) + :signal (list 'child-detached + #'(lambda (child) + (format t "~A detached~%" child)))) + :expand nil :fill :nil)) + :child (make-instance 'h-separator) + :child (create-label "Below"))) ;;; Image @@ -813,7 +705,7 @@ (defun create-menu (depth tearoff) (make-instance 'radio-menu-item :label (format nil "item ~2D - ~D" depth (1+ i))))) (if group - (radio-menu-item-add-to-group menu-item group) + (add-to-radio-group menu-item group) (setq group menu-item)) (unless (zerop (mod depth 2)) (setf (check-menu-item-active-p menu-item) t)) @@ -830,7 +722,7 @@ (define-simple-dialog create-menus (dialog "Menus" :default-width 200) (let* ((main (make-instance 'v-box :parent dialog)) ; (accel-group (make-instance 'accel-group)) (menubar (make-instance 'menu-bar :parent (list main :expand nil)))) -; (accel-group-attach accel-group window) +; (window-add-accel-group dialog accel-group) (let ((menu-item (make-instance 'menu-item :label (format nil "test~%line2")))) @@ -927,13 +819,12 @@ (define-simple-dialog create-notebook (dialog "Notebook") (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) - (set-image page #'notebook-tab-label book-open) + (set-image page #'notebook-menu-label book-open) + (set-image page #'notebook-tab-label book-open) + (when (slot-boundp notebook 'current-page) (let ((curpage (notebook-current-page notebook))) - (when curpage - (set-image curpage #'notebook-menu-label book-closed) - (set-image curpage #'notebook-tab-label book-closed))))))) + (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)) @@ -1106,7 +997,9 @@ (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 - :children (create-radio-button-group '("button1" "button2" "button3") 1))) + :children (make-radio-group 'radio-button + '((:label "button1") (:label "button2") (:label "button3")) + nil))) ;;; Rangle controls @@ -1472,11 +1365,10 @@ (define-simple-dialog create-idle-test (dialog "Idle Test") :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)))))) @@ -1548,8 +1440,8 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400 (if active (push tag active-tags) (setq active-tags (delete tag active-tags))) - (multiple-value-bind (start end) - (text-buffer-get-selection-bounds buffer) + (multiple-value-bind (non-zero-p start end) + (text-buffer-get-selection-bounds buffer) (if active (text-buffer-apply-tag buffer tag start end) (text-buffer-remove-tag buffer tag start end)))))))) @@ -1625,108 +1517,94 @@ (define-simple-dialog create-toggle-buttons (dialog "Toggle Button") ;;; 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))) - - )) +(defun create-toolbar (window) + (make-instance 'toolbar + :show-tooltips t :show-arrow nil + + ;; 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+") + )) + +(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil) + (container-add window (create-toolbar window))) @@ -1841,7 +1719,7 @@ (defun create-main-window () ("enxpander" create-expander) ("file chooser" create-file-chooser) ;; ("font selection") -;; ("handle box" create-handle-box) + ("handle box" create-handle-box) ("image" create-image) ("labels" create-labels) ("layout" create-layout) @@ -1869,7 +1747,7 @@ (defun create-main-window () ("test timeout" create-timeout-test) ("text" create-text) ("toggle buttons" create-toggle-buttons) - ("toolbar" create-toolbar) + ("toolbar" create-toolbar-window) ("tooltips" create-tooltips) ;; ("tree" #|create-tree|#) ("UI manager" create-ui-manager)