;; 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.15 2005-01-06 21:59:51 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.18 2005-02-25 23:58:56 espen Exp $
;(use-package "GTK")
`(let ((,window nil))
(defun ,name ()
(unless ,window
- (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
+ (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
,@body)
(if (not (widget-visible-p ,window))
- (widget-show-all ,window)
+ (widget-show ,window)
(widget-hide ,window)))))
`(let ((,dialog nil))
(defun ,name ()
(unless ,dialog
- (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
+ (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
,@body)
(define-toplevel create-button-box (window "Button Boxes")
(make-instance 'v-box
- :parent window :border-width 10 :spacing 10 :show-all t
+ :parent window :border-width 10 :spacing 10
:child (make-instance 'frame
:label "Horizontal Button Boxes"
:child (make-instance 'v-box
(widget-hide button+1)
(widget-show button+1))))
(table-attach table button column (1+ column) row (1+ row)
- :options '(:expand :fill)))))
- (widget-show-all table)))
+ :options '(:expand :fill)))))))
;; Calenadar
(define-simple-dialog create-calendar (dialog "Calendar")
(make-instance 'v-box
- :parent dialog :border-width 10 :show-all t
+ :parent dialog :border-width 10
:child (make-instance 'calendar)))
(define-simple-dialog create-check-buttons (dialog "Check Buttons")
(make-instance 'v-box
- :border-width 10 :spacing 10 :parent dialog :show-all t
+ :border-width 10 :spacing 10 :parent dialog
:children (loop
for n from 1 to 3
collect (make-instance 'check-button
(define-dialog create-color-selection (dialog "Color selection dialog"
'color-selection-dialog
- :allow-grow nil :allow-shrink nil)
- (with-slots (action-area colorsel) dialog
-;; This seg faults for some unknown reason
-;; (let ((button (make-instance 'check-button :label "Show Palette")))
-;; (dialog-add-action-widget dialog button
-;; #'(lambda ()
-;; (setf
-;; (color-selection-has-palette-p colorsel)
-;; (toggle-button-active-p button)))))
-
- (container-add action-area
- (create-check-button "Show Opacity"
- #'(lambda (state)
- (setf (color-selection-has-opacity-control-p colorsel) state))))
-
- (container-add action-area
- (create-check-button "Show Palette"
- #'(lambda (state)
- (setf (color-selection-has-palette-p colorsel) state))))
+ :allow-grow nil :allow-shrink nil
+ :show-children nil)
+ (with-slots (colorsel) dialog
+ (let ((button (make-instance 'check-button :label "Show Opacity")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-opacity-control-p colorsel)
+ (toggle-button-active-p button)))))
+
+ (let ((button (make-instance 'check-button :label "Show Palette")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-palette-p colorsel)
+ (toggle-button-active-p button)))))
(signal-connect dialog :ok
#'(lambda ()
(signal-connect drawing-area 'button-press-event
#'(lambda (event)
(case (gdk:event-button event)
- (1 (spin-button-spin spinner :step-forward 0.0))
- (3 (spin-button-spin spinner :step-backward 0.0)))
+ (1 (spin-button-spin spinner :step-forward))
+ (3 (spin-button-spin spinner :step-backward)))
t))
(signal-connect drawing-area 'scroll-event
#'(lambda (event)
(case (gdk:event-direction event)
- (:up (spin-button-spin spinner :step-forward 0.0))
- (:down (spin-button-spin spinner :step-backward 0.0)))
+ (:up (spin-button-spin spinner :step-forward))
+ (:down (spin-button-spin spinner :step-backward)))
t))
(signal-connect spinner 'changed
(set-cursor spinner drawing-area label)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 5 :show-all t
+ :parent dialog :border-width 10 :spacing 5
:child (list
(make-instance 'h-box
:border-width 5
:child spinner)
:expand nil)
:child (make-instance 'frame
-; :shadow-type :etched-in
:label "Cursor Area" :label-xalign 0.5 :border-width 10
:child drawing-area)
:child (list label :expand nil))
(create-check-button "Editable" 'editable)
(create-check-button "Visible" 'visibility)
- (create-check-button "Sensitive" 'sensitive)))
- (widget-show-all main)))
+ (create-check-button "Sensitive" 'sensitive)))))
;; Expander
(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
(make-instance 'v-box
- :parent dialog :spacing 5 :border-width 5 :show-all t
+ :parent dialog :spacing 5 :border-width 5
:child (create-label "Expander demo. Click on the triangle for details.")
:child (make-instance 'expander
:label "Details"
(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
(let ((layout (make-instance 'layout
:parent (make-instance 'scrolled-window :parent window)
:width 1600 :height 128000 :events '(:exposure-mask)
- :signal (list 'expose-event #'layout-expose :object t)
- )))
+ :signal (list 'expose-event #'layout-expose :object t))))
(with-slots (hadjustment vadjustment) layout
(setf
(dotimes (i 16)
(dotimes (j 16)
(let ((text (format nil "Button ~D, ~D" i j)))
- (make-instance (if (not (zerop (mod (+ i j) 2)))
- 'button
- 'label)
- :label text :parent (list layout :x (* j 100) :y (* i 100))))))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod (+ i j) 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ (* j 100) (* i 100)))))
(loop
for i from 16 below 1280
do (let ((text (format nil "Button ~D, ~D" i 0)))
- (make-instance (if (not (zerop (mod i 2)))
- 'button
- 'label)
- :label text :parent (list layout :x 0 :y (* i 100)))))))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod i 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ 0 (* i 100))))))
(tree-view-append-column tree column))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (list
(make-instance 'h-box
:spacing 10
(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 (list 'clicked #'(lambda () (widget-hide page)))))
(let ((label-box (make-instance 'h-box
- :show-all t
+ :show-children t
:child-args '(:expand nil)
:child (make-instance 'image :pixbuf book-closed)
:child (make-instance 'label :label title)))
(menu-box (make-instance 'h-box
- :show-all t
+ :show-children t
:child-args '(:expand nil)
:child (make-instance 'image :pixbuf book-closed)
:child (make-instance 'label :label title))))
(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))
t))))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child progress
:child activity-mode-button)
(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:children (make-radio-group 'radio-button
'((:label "button1") (:label "button2") (:label "button3"))
nil)))
(define-simple-dialog create-range-controls (dialog "Range controls")
(let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (make-instance 'h-scale
:width-request 150 :adjustment adjustment :inverted t
:update-policy :delayed :digits 1 :draw-value t)
(make-instance 'frame :label label :child table))))
(make-instance 'v-box
- :parent dialog :border-width 5 :spacing 5 :show-all t
+ :parent dialog :border-width 5 :spacing 5
:child (create-frame "Color Options"
'(("Foreground" "Red" "Green" "Blue")
("Background" "Red" "Green" "Blue")))
#'(lambda () (when idle (idle-remove idle))))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child label
:child (make-instance 'frame
:label "Label Container" :border-width 5
(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)
+ (declare (ignore non-zero-p))
(if active
(text-buffer-apply-tag buffer tag start end)
(text-buffer-remove-tag buffer tag start end))))))))
(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
(make-instance 'v-box
- :border-width 10 :spacing 10 :parent dialog :show-all t
+ :border-width 10 :spacing 10 :parent dialog
:children (loop
for n from 1 to 3
collect (make-instance 'toggle-button
;;; Toolbar test
-(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
+(defun create-toolbar (window)
(make-instance 'toolbar
- :show-tooltips t :show-arrow nil :parent window
+ :show-tooltips t :show-arrow nil
;; Insert a stock item
:child (make-instance 'tool-button
;; :tip-private "Toolbar/GTK+")
))
+(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
+ (container-add window (create-toolbar window)))
+
;;; Tooltips test
(tooltips-set-tip tooltips button tip-text tip-private)
button)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (create-button "button1" "This is button 1" "ContextHelp/button/1")
: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")))))
(window-add-accel-group window (ui-manager-accel-group ui))
(make-instance 'v-box
- :parent window :show-all t
+ :parent window
:child (list
(ui-manager-get-widget ui "/MenuBar")
:expand nil :fill nil)
("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