;; 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.12 2004/12/20 00:56:11 espen Exp $
+;; $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
: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))
(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
(dialog-add-button dialog "gtk-ok"
#'(lambda ()
- (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+ (if (slot-boundp dialog 'filename)
+ (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+ (write-line "No files selected"))
(widget-destroy dialog))))
(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"
;;; Panes
(defun toggle-resize (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child (not resize) shrink)
- (paned-pack2 paned child (not resize) shrink)))))
+ (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
(defun toggle-shrink (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child resize (not shrink))
- (paned-pack2 paned child resize (not shrink))))))
+ (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
(defun create-pane-options (paned frame-label label1 label2)
- (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
- (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
- :parent frame)))
-
+ (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
(table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
(let ((check-button (make-instance 'check-button :label "Resize")))
(table-attach table check-button 0 1 1 2 :options '(:expand :fill))
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child1 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
(table-attach table check-button 0 1 2 3 :options '(:expand :fill))
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child1 paned)))
(table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
- (let ((check-button (make-instance 'check-button :label "Resize")))
+ (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
(table-attach table check-button 1 2 1 2 :options '(:expand :fill))
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child2 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
(table-attach table check-button 1 2 2 3 :options '(:expand :fill))
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
- frame))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child2 paned)))
+ (make-instance 'frame :label frame-label :border-width 4 :child table)))
(define-toplevel create-panes (window "Panes")
(let* ((hpaned (make-instance 'h-paned
:child1 (make-instance 'frame
:width-request 60 :height-request 60
:shadow-type :in
- :child (make-instance 'buttun :label "Hi there"))
+ :child (make-instance 'button :label "Hi there"))
:child2 (make-instance 'frame
:width-request 80 :height-request 60
:shadow-type :in)))
;;; 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-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))
;;; Toolbar test
-;; TODO: style properties
(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
(let ((toolbar (make-instance 'toolbar :parent window)))
-; (setf (toolbar-relief toolbar) :none)
;; Insert a stock item
(toolbar-append toolbar "gtk-quit"
(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")))))
+ :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")))))
;;; UI Manager
;; ("font selection")
;; ("handle box" create-handle-box)
("image" create-image)
-;; ("item factory")
("labels" create-labels)
("layout" create-layout)
("list" create-list)
;; ("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))))
+ (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
:parent main-window
~mdw / clg / blobdiff