;; 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.10 2004-12-05 13:57:10 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.19 2005-02-26 10:44:11 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)
: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
- :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
(if (widget-visible-p button+1)
(widget-hide button+1)
(widget-show button+1))))
- (table-attach table button column (1+ column) row (1+ row)))))
- (widget-show-all table)))
+ (table-attach table button column (1+ column) row (1+ row)
+ :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 ()
(declare (number n min-val max-val))
(max (min n max-val) min-val))
+(defun set-cursor (spinner drawing-area label)
+ (let ((cursor
+ (glib:int-enum
+ (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
+ 'gdk:cursor-type)))
+ (setf (label-label label) (string-downcase cursor))
+ (setf (widget-cursor drawing-area) cursor)))
+
+(defun cursor-expose (drawing-area event)
+ (declare (ignore event))
+ (multiple-value-bind (width height)
+ (widget-get-size-allocation drawing-area)
+ (let* ((window (widget-window drawing-area))
+ (style (widget-style drawing-area))
+ (white-gc (style-white-gc style))
+ (gray-gc (style-bg-gc style :normal))
+ (black-gc (style-black-gc style)))
+ (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
+ (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
+ (floor height 2))
+ (gdk:draw-rectangle window gray-gc t (floor width 3)
+ (floor height 3) (floor width 3)
+ (floor height 3))))
+ t)
+
+(define-simple-dialog create-cursors (dialog "Cursors")
+ (let ((spinner (make-instance 'spin-button
+ :adjustment (adjustment-new
+ 0 0
+ (1- (enum-int :last-cursor 'gdk:cursor-type))
+ 2 10 0)))
+ (drawing-area (make-instance 'drawing-area
+ :width-request 80 :height-request 80
+ :events '(:exposure :button-press)))
+ (label (make-instance 'label :label "XXX")))
+
+ (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
+
+ (signal-connect drawing-area 'button-press-event
+ #'(lambda (event)
+ (case (gdk:event-button event)
+ (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))
+ (:down (spin-button-spin spinner :step-backward)))
+ t))
+
+ (signal-connect spinner 'changed
+ #'(lambda ()
+ (set-cursor spinner drawing-area label)))
-;; (defun set-cursor (spinner drawing-area label)
-;; (let ((cursor
-;; (glib:int-enum
-;; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
-;; 'gdk:cursor-type)))
-;; (setf (label-text label) (string-downcase cursor))
-;; (setf (widget-cursor drawing-area) cursor)))
-
-
-; (define-standard-dialog create-cursors "Cursors"
-; (setf (container-border-width main-box) 10)
-; (setf (box-spacing main-box) 5)
-; (let* ((hbox (hbox-new nil 0))
-; (label (create-label "Cursor Value : "))
-; (adj (adjustment-new 0 0 152 2 10 0))
-; (spinner (spin-button-new adj 0 0)))
-; (setf (container-border-width hbox) 5)
-; (box-pack-start main-box hbox nil t 0)
-; (setf (misc-xalign label) 0)
-; (setf (misc-yalign label) 0.5)
-; (box-pack-start hbox label nil t 0)
-; (box-pack-start hbox spinner t t 0)
-
-; (let ((frame (make-frame
-; :shadow-type :etched-in
-; :label-xalign 0.5
-; :label "Cursor Area"
-; :border-width 10
-; :parent main-box
-; :visible t))
-; (drawing-area (drawing-area-new)))
-; (setf (widget-width drawing-area) 80)
-; (setf (widget-height drawing-area) 80)
-; (container-add frame drawing-area)
-; (signal-connect
-; drawing-area 'expose-event
-; #'(lambda (event)
-; (declare (ignore event))
-; (multiple-value-bind (width height)
-; (drawing-area-size drawing-area)
-; (let* ((drawable (widget-window drawing-area))
-; (style (widget-style drawing-area))
-; (white-gc (style-get-gc style :white))
-; (gray-gc (style-get-gc style :background :normal))
-; (black-gc (style-get-gc style :black)))
-; (gdk:draw-rectangle
-; drawable white-gc t 0 0 width (floor height 2))
-; (gdk:draw-rectangle
-; drawable black-gc t 0 (floor height 2) width (floor height 2))
-; (gdk:draw-rectangle
-; drawable gray-gc t (floor width 3) (floor height 3)
-; (floor width 3) (floor height 3))))
-; t))
-; (setf (widget-events drawing-area) '(:exposure :button-press))
-; (signal-connect
-; drawing-area 'button-press-event
-; #'(lambda (event)
-; (when (and
-; (eq (gdk:event-type event) :button-press)
-; (or
-; (= (gdk:event-button event) 1)
-; (= (gdk:event-button event) 3)))
-; (spin-button-spin
-; spinner
-; (if (= (gdk:event-button event) 1)
-; :step-forward
-; :step-backward)
-; 0)
-; t)))
-; (widget-show drawing-area)
-
-; (let ((label (make-label
-; :visible t
-; :label "XXX"
-; :parent main-box)))
-; (setf (box-child-expand-p #|main-box|# label) nil)
-; (signal-connect
-; spinner 'changed
-; #'(lambda ()
-; (set-cursor spinner drawing-area label)))
-
-; (widget-realize drawing-area)
-; (set-cursor spinner drawing-area label)))))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 5
+ :child (list
+ (make-instance 'h-box
+ :border-width 5
+ :child (list
+ (make-instance 'label :label "Cursor Value : ")
+ :expand nil)
+ :child spinner)
+ :expand nil)
+ :child (make-instance 'frame
+ :label "Cursor Area" :label-xalign 0.5 :border-width 10
+ :child drawing-area)
+ :child (list label :expand nil))
+ (widget-realize drawing-area)
+ (set-cursor spinner drawing-area label)))
;;; Dialog
(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 ()
- (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))))
;;; 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
;;; Layout
-;; (defun layout-expose (layout event)
-;; (with-slots (window x-offset y-offset) layout
-;; (with-slots (x y width height) event
-;; (let ((imin (truncate (+ x-offset x) 10))
-;; (imax (truncate (+ x-offset x width 9) 10))
-;; (jmin (truncate (+ y-offset y) 10))
-;; (jmax (truncate (+ y-offset y height 9) 10)))
-;; (declare (fixnum imin imax jmin jmax))
-;; (gdk:window-clear-area window x y width height)
-
-;; (let ((window (layout-bin-window layout))
-;; (gc (style-get-gc (widget-style layout) :black)))
-;; (do ((i imin (1+ i)))
-;; ((= i imax))
-;; (declare (fixnum i))
-;; (do ((j jmin (1+ j)))
-;; ((= j jmax))
-;; (declare (fixnum j))
-;; (unless (zerop (mod (+ i j) 2))
-;; (gdk:draw-rectangle
-;; window gc t
-;; (- (* 10 i) x-offset) (- (* 10 j) y-offset)
-;; (1+ (mod i 10)) (1+ (mod j 10))))))))))
-;; t)
-
+(defun layout-expose (layout event)
+ (when (eq (gdk:event-window event) (layout-bin-window layout))
+ (with-slots (gdk:x gdk:y gdk:width gdk:height) event
+ (let ((imin (truncate gdk:x 10))
+ (imax (truncate (+ gdk:x gdk:width 9) 10))
+ (jmin (truncate gdk:y 10))
+ (jmax (truncate (+ gdk:y gdk:height 9) 10)))
+
+ (let ((window (layout-bin-window layout))
+ (gc (style-black-gc (widget-style layout))))
+ (loop
+ for i from imin below imax
+ do (loop
+ for j from jmin below jmax
+ unless (zerop (mod (+ i j) 2))
+ do (gdk:draw-rectangle
+ window gc t (* 10 i) (* 10 j)
+ (1+ (mod i 10)) (1+ (mod j 10)))))))))
+ nil)
(define-toplevel create-layout (window "Layout" :default-width 200
:default-height 200)
(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)
- )))
+ :width 1600 :height 128000 :events '(:exposure)
+ :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))
(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)))
(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"))))
;;; 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
: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 :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
+ :show-children 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)
+ (when (slot-boundp notebook 'current-page)
(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))
+ (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)))
-
- (table-attach table (create-label label1) 0 1 0 1)
- (let ((check-button (make-instance 'check-button :label "Resize")))
- (table-attach table check-button 0 1 1 2)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
- (table-attach table check-button 0 1 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
-
- (table-attach table (create-label label2) 1 2 0 1)
+ (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 1 2 1 2)
- (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")))
- (table-attach table check-button 1 2 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
- frame))
+ (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" :active t)))
+ (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
+ (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" :active t)))
+ (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
+ (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))
+ (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
+ :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)))
+ :parent dialog :border-width 10 :spacing 10
+ :children (make-radio-group 'radio-button
+ '((:label "button1") (:label "button2") (:label "button3"))
+ nil)))
;;; Rangle controls
(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)
(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))
(define-toplevel create-rulers (window "Rulers"
:default-width 300 :default-height 300
-;; :events '(:pointer-motion-mask
-;; :pointer-motion-hint-mask)
- )
- (setf
- (widget-events window)
- '(:pointer-motion-mask :pointer-motion-hint-mask))
-
- (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
- (let ((ruler (make-instance 'h-ruler
+ :events '(:pointer-motion :pointer-motion-hint))
+ (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
+ (h-ruler (make-instance 'h-ruler
:metric :centimeters :lower 100.0d0 :upper 0.0d0
- :position 0.0d0 :max-size 20.0d0)))
- (signal-connect window 'motion-notify-event #'widget-event :object ruler)
- (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
- (let ((ruler (make-instance 'v-ruler
+ :position 0.0d0 :max-size 20.0d0))
+ (v-ruler (make-instance 'v-ruler
:lower 5.0d0 :upper 15.0d0
:position 0.0d0 :max-size 20.0d0)))
- (signal-connect window 'motion-notify-event #'widget-event :object ruler)
- (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
-
+ (signal-connect window 'motion-notify-event
+ #'(lambda (event)
+ (widget-event h-ruler event)
+ (widget-event v-ruler event)))
+ (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
+ (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
;;; Scrolled window
(widget-show-all scrolled-window)))
+;;; Size group
+
+(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
+ (let ((size-group (make-instance 'size-group)))
+ (flet ((create-frame (label rows)
+ (let ((table (make-instance 'table
+ :n-rows (length rows) :n-columns 2 :homogeneous nil
+ :row-spacing 5 :column-spacing 10 :border-width 5)))
+ (loop
+ for row in rows
+ for i from 0
+ do (table-attach table
+ (create-label (first row) :xalign 0 :yalign 1)
+ 0 1 i (1+ i) :x-options '(:expand :fill))
+ (let ((combo (make-instance 'combo-box
+ :content (rest row) :active 0)))
+ (size-group-add-widget size-group combo)
+ (table-attach table combo 1 2 i (1+ i))))
+ (make-instance 'frame :label label :child table))))
+
+ (make-instance 'v-box
+ :parent dialog :border-width 5 :spacing 5
+ :child (create-frame "Color Options"
+ '(("Foreground" "Red" "Green" "Blue")
+ ("Background" "Red" "Green" "Blue")))
+ :child (create-frame "Line Options"
+ '(("Dashing" "Solid" "Dashed" "Dotted")
+ ("Line ends" "Square" "Round" "Arrow")))
+ :child (create-check-button "Enable grouping"
+ #'(lambda (active)
+ (setf
+ (size-group-mode size-group)
+ (if active :horizontal :none)))
+ t)))))
+
+
;;; Shapes
;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
#'(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
: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))))))
(define-simple-dialog create-text (dialog "Text" :default-width 400
:default-height 400)
- (make-instance 'text-view :border-width 10 :parent dialog :visible t))
+ (let* ((text-view (make-instance 'text-view
+ :border-width 10 :visible t :wrap-mode :word))
+ (buffer (text-view-buffer text-view))
+ (active-tags ()))
+
+ (text-buffer-create-tag buffer "Bold" :weight :bold)
+ (text-buffer-create-tag buffer "Italic" :style :italic)
+ (text-buffer-create-tag buffer "Underline" :underline :single)
+
+ (flet ((create-toggle-callback (tag-name)
+ (let ((tag (text-tag-table-lookup
+ (text-buffer-tag-table buffer) tag-name)))
+ #'(lambda (active)
+ (unless (eq (and (find tag active-tags) t) active)
+ ;; user activated
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (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))))))))
+
+ (let* ((actions
+ (make-instance 'action-group
+ :action (create-toggle-action
+ "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
+ (create-toggle-callback "Bold"))
+ :action (create-toggle-action
+ "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
+ (create-toggle-callback "Italic"))
+ :action (create-toggle-action
+ "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
+ (create-toggle-callback "Underline"))))
+ (ui (make-instance 'ui-manager)))
+
+ (ui-manager-insert-action-group ui actions)
+ (ui-manager-add-ui ui
+ '((:toolbar "ToolBar"
+ (:toolitem "Bold")
+ (:toolitem "Italic")
+ (:toolitem "Underline"))))
+
+ ;; Callback to activate/deactivate toolbar buttons when cursor
+ ;; is moved
+ (signal-connect buffer 'mark-set
+ #'(lambda (location mark)
+ (declare (ignore mark))
+ (text-tag-table-foreach (text-buffer-tag-table buffer)
+ #'(lambda (tag)
+ (let ((active
+ (or
+ (and
+ (text-iter-has-tag-p location tag)
+ (not (text-iter-begins-tag-p location tag)))
+ (text-iter-ends-tag-p location tag))))
+ (unless (eq active (and (find tag active-tags) t))
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (setf
+ (toggle-action-active-p
+ (action-group-get-action actions (text-tag-name tag)))
+ active)))))))
+
+ ;; Callback to apply active tags when a character is inserted
+ (signal-connect buffer 'insert-text
+ #'(lambda (iter &rest args)
+ (declare (ignore args))
+ (let ((before (text-buffer-get-iter-at-offset buffer
+ (1- (text-iter-offset iter)))))
+ (loop
+ for tag in active-tags
+ do (text-buffer-apply-tag buffer tag before iter))))
+ :after t)
+
+ (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
+ (container-add dialog text-view)))))
+
;;; Toggle buttons
(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
-;; 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"
- :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)))
(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 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")))
-
- (let ((close-button (first (container-children (dialog-action-area dialog)))))
- (tooltips-set-tip tooltips close-button "Push this button to close window"
- "ContextHelp/buttons/Close"))))
+ :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
(:separator "Sep1")
(:toolitem "Logo"))))
-(define-simple-dialog create-ui-manager (dialog "UI Manager")
+(define-toplevel create-ui-manager (window "UI Manager")
(let ((actions
(make-instance 'action-group
:name "Actions"
:action (create-action "ShapeMenu" nil "_Shape")
:action (create-action "HelpMenu" nil "_Help")
:action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
- :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
+ :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
:action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
:action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
- :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
+ :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
:action (create-action "About" nil "_About" "<control>A" "About")
:action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
:action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
(ui-manager-insert-action-group ui actions)
(ui-manager-add-ui ui *ui-description*)
- (window-add-accel-group dialog (ui-manager-accel-group ui))
+ (window-add-accel-group window (ui-manager-accel-group ui))
(make-instance 'v-box
- :parent dialog :show-all t
+ :parent window
:child (list
(ui-manager-get-widget ui "/MenuBar")
:expand nil :fill nil)
("calendar" create-calendar)
("check buttons" create-check-buttons)
("color selection" create-color-selection)
-;; ("cursors" #|create-cursors|#)
+ ("cursors" create-cursors)
("dialog" create-dialog)
;; ; ("dnd")
("entry" create-entry)
("enxpander" create-expander)
("file chooser" create-file-chooser)
;; ("font selection")
-;; ("handle box" create-handle-box)
+ ("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")
("rulers" create-rulers)
;; ("saved position")
("scrolled windows" create-scrolled-windows)
+ ("size group" create-size-group)
;; ("shapes" create-shapes)
("spinbutton" create-spins)
("statusbar" create-statusbar)
("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)
: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