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