;; 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
;; 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")
(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))))
;;; 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
(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))
(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"))))
(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))
(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
: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))))))
(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))))))))
;;; 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)))
("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)
("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)
~mdw / clg / blobdiff