-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 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 as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
;;
-;; You should have received a copy 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
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: testgtk.lisp,v 1.18 2005-02-25 23:58:56 espen Exp $
+;; Parts of this file are direct translations of code from 'testgtk.c'
+;; distributed with the Gtk+ library, and thus covered by the GNU
+;; Lesser General Public License and copyright Peter Mattis, Spencer
+;; Kimball, Josh MacDonald and others.
-;(use-package "GTK")
-(in-package "GTK")
+;; $Id: testgtk.lisp,v 1.31 2005-04-25 18:13:32 espen Exp $
+
+#+sbcl(require :gtk)
+#+cmucl(asdf:oos 'asdf:load-op :gtk)
+
+(defpackage "TESTGTK"
+ (:use "COMMON-LISP" "GTK"))
+
+(in-package "TESTGTK")
(defmacro define-toplevel (name (window title &rest initargs) &body body)
`(let ((,window nil))
(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
,@body)
- (if (not (widget-visible-p ,window))
- (widget-show ,window)
- (widget-hide ,window)))))
+ (when ,window
+ (if (not (widget-visible-p ,window))
+ (widget-show ,window)
+ (widget-hide ,window))))))
(defmacro define-dialog (name (dialog title &optional (class 'dialog)
(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
,@body)
- (if (not (widget-visible-p ,dialog))
- (widget-show ,dialog)
- (widget-hide ,dialog)))))
+ (when ,dialog
+ (if (not (widget-visible-p ,dialog))
+ (widget-show ,dialog)
+ (widget-hide ,dialog))))))
(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
(let ((spinner (make-instance 'spin-button
:adjustment (adjustment-new
0 0
- (1- (enum-int :last-cursor 'gdk:cursor-type))
+ (1- (glib:enum-int :last-cursor 'gdk:cursor-type))
2 10 0)))
(drawing-area (make-instance 'drawing-area
:width-request 80 :height-request 80
- :events '(:exposure-mask :button-press-mask)))
+ :events '(:exposure :button-press)))
(label (make-instance 'label :label "XXX")))
(signal-connect drawing-area 'expose-event #'cursor-expose :object t)
;; File chooser dialog
(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
+ (file-chooser-add-filter dialog
+ (make-instance 'file-filter :name "All files" :pattern "*"))
+ (file-chooser-add-filter dialog
+ (make-instance 'file-filter :name "Common Lisp source code"
+ :patterns '("*.lisp" "*.lsp")))
+
(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
(dialog-add-button dialog "gtk-ok"
#'(lambda ()
(widget-destroy dialog))))
+;; Font selection dialog
+
+(define-toplevel create-font-selection (window "Font Button" :resizable nil)
+ (make-instance 'h-box
+ :parent window :spacing 8 :border-width 8
+ :child (make-instance 'label :label "Pick a font")
+ :child (make-instance 'font-button
+ :use-font t :title "Font Selection Dialog")))
+
+
+;;; Icon View
+
+#+gtk2.6
+(let ((file-pixbuf nil)
+ (folder-pixbuf nil))
+ (defun load-pixbufs ()
+ (unless file-pixbuf
+ (handler-case
+ (setf
+ file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
+ folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
+ (glib:glib-error (condition)
+ (make-instance 'message-dialog
+ :message-type :error :visible t
+ :text "<b>Failed to load an image</b>"
+ :secondary-text (glib:gerror-message condition)
+ :signal (list :close #'widget-destroy :object t))
+ (return-from load-pixbufs nil))))
+ t)
+
+ (defun fill-store (store directory)
+ (list-store-clear store)
+ (let ((dir #+cmu(unix:open-dir directory)
+ #+sbcl(sb-posix:opendir directory)))
+ (unwind-protect
+ (loop
+ as filename = #+cmu(unix:read-dir dir)
+ #+sbcl(let ((dirent (sb-posix:readdir dir)))
+ (unless (sb-grovel::foreign-nullp dirent)
+ (sb-posix:dirent-name dirent)))
+ while filename
+ unless (or (equal filename ".") (equal filename ".."))
+ do (let* ((pathname (format nil "~A~A" directory filename))
+ (directory-p
+ #+cmu(eq (unix:unix-file-kind pathname) :directory)
+ #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
+ (list-store-append store
+ (vector
+ filename
+ (if directory-p folder-pixbuf file-pixbuf)
+ directory-p))))
+ #+cmu(unix:close-dir dir)
+ #+sbcl(sb-posix:closedir dir))))
+
+ (defun sort-func (store a b)
+ (let ((a-dir-p (tree-model-value store a 'directory-p))
+ (b-dir-p (tree-model-value store b 'directory-p))
+ (a-name (tree-model-value store a 'filename))
+ (b-name (tree-model-value store b 'filename)))
+ (cond
+ ((and a-dir-p (not b-dir-p)) :before)
+ ((and (not a-dir-p) b-dir-p) :after)
+ ((string< a-name b-name) :before)
+ ((string> a-name b-name) :after)
+ (t :equal))))
+
+ (defun parent-dir (dir)
+ (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
+ (subseq dir 0 end)))
+
+ (define-toplevel create-icon-view (window "Icon View demo"
+ :default-width 650
+ :default-height 400)
+ (if (not (load-pixbufs))
+ (widget-destroy window)
+ (let* ((directory "/")
+ (store (make-instance 'list-store
+ :column-types '(string gdk:pixbuf boolean)
+ :column-names '(filename pixbuf directory-p)))
+ (icon-view (make-instance 'icon-view
+ :model store :selection-mode :multiple
+ :text-column 'filename :pixbuf-column 'pixbuf))
+ (up (make-instance 'tool-button
+ :stock "gtk-go-up" :is-important t :sensitive nil))
+ (home (make-instance 'tool-button
+ :stock "gtk-home" :is-important t)))
+ (tree-sortable-set-sort-func store :default #'sort-func)
+ (tree-sortable-set-sort-column store :default :ascending)
+ (fill-store store directory)
+
+ (signal-connect icon-view 'item-activated
+ #'(lambda (path)
+ (when (tree-model-value store path 'directory-p)
+ (setq directory
+ (concatenate 'string directory (tree-model-value store path 'filename) "/"))
+ (fill-store store directory)
+ (setf (widget-sensitive-p up) t))))
+
+ (signal-connect up 'clicked
+ #'(lambda ()
+ (unless (string= directory "/")
+ (setq directory (parent-dir directory))
+ (fill-store store directory)
+ (setf
+ (widget-sensitive-p home)
+ (not (string= directory (namestring (truename #p"clg:")))))
+ (setf (widget-sensitive-p up) (not (string= directory "/"))))))
+
+ (signal-connect home 'clicked
+ #'(lambda ()
+ (setq directory (namestring (truename #p"clg:")))
+ (fill-store store directory)
+ (setf (widget-sensitive-p up) t)
+ (setf (widget-sensitive-p home) nil)))
+
+ (make-instance 'v-box
+ :parent window
+ :child (list
+ (make-instance 'toolbar :child up :child home)
+ :fill nil :expand nil)
+ :child (make-instance 'scrolled-window
+ :shadow-type :etched-in :policy :automatic
+ :child icon-view))))))
-;;; Handle box
-
-(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
-(define-toplevel create-image (window "Image")
+(define-toplevel create-image (window "Image" :resizable nil)
(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
:justify :fill :wrap t)
:child (create-label-in-frame "Underlined label"
+(#+cmu glib:latin1-to-unicode #+sbcl identity
"This label is underlined!
-This one is underlined (こんにちは) in quite a funky fashion"
+This one is underlined (æøåÆØÅ) in quite a funky fashion")
:justify :left
:pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
:default-height 200)
(let ((layout (make-instance 'layout
:parent (make-instance 'scrolled-window :parent window)
- :width 1600 :height 128000 :events '(:exposure-mask)
+ :width 1600 :height 128000 :events '(:exposure)
:signal (list 'expose-event #'layout-expose :object t))))
(with-slots (hadjustment vadjustment) layout
(define-simple-dialog create-list (dialog "List" :default-height 400)
(let* ((store (make-instance 'list-store
- :column-types '(string int boolean)
+ :column-types '(string integer boolean)
:column-names '(:foo :bar :baz)
:initial-content '(#("First" 12321 nil)
(:foo "Yeah" :baz t))))
(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))
-
+ :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
;;; Shapes
-;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
-;; (let* ((window
-;; (make-instance 'window
-;; :type type :x x :y y
-;; :events '(:button-motion :pointer-motion-hint :button-press)))
-;; (fixed
-;; (make-instance 'fixed
-;; :parent window :width 100 :height 100)))
+(defun create-shape-icon (xpm-file x y px py type root-window destroy)
+ (let ((window
+ (make-instance 'window
+ :type type :default-width 100 :default-height 100
+ :events '(:button-motion :pointer-motion-hint :button-press)
+ :signal (list 'destroy destroy))))
-;; (widget-realize window)
-;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
-;; (let ((pixmap (pixmap-new source mask))
-;; (x-offset 0)
-;; (y-offset 0))
-;; (declare (fixnum x-offset y-offset))
-;; (fixed-put fixed pixmap px py)
-;; (widget-shape-combine-mask window mask px py)
+ (widget-realize window)
+ (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
+ (let ((fixed (make-instance 'fixed :parent window)))
+ (fixed-put fixed (create-image-widget source mask) px py))
+ (widget-shape-combine-mask window mask px py))
-;; (signal-connect window 'button-press-event
-;; #'(lambda (event)
-;; (when (typep event 'gdk:button-press-event)
-;; (setq x-offset (truncate (gdk:event-x event)))
-;; (setq y-offset (truncate (gdk:event-y event)))
-;; (grab-add window)
-;; (gdk:pointer-grab
-;; (widget-window window) t
-;; '(:button-release :button-motion :pointer-motion-hint)
-;; nil nil 0))
-;; t))
-
-;; (signal-connect window 'button-release-event
-;; #'(lambda (event)
-;; (declare (ignore event))
-;; (grab-remove window)
-;; (gdk:pointer-ungrab 0)
-;; t))
+ (let ((x-offset 0)
+ (y-offset 0))
+ (declare (fixnum x-offset y-offset))
+ (signal-connect window 'button-press-event
+ #'(lambda (event)
+ (when (typep event 'gdk:button-press-event)
+ (setq x-offset (truncate (gdk:event-x event)))
+ (setq y-offset (truncate (gdk:event-y event)))
+ (grab-add window)
+ (gdk:pointer-grab (widget-window window)
+ :events '(:button-release :button-motion :pointer-motion-hint)
+ :owner-events t))))
+
+ (signal-connect window 'button-release-event
+ #'(lambda (event)
+ (declare (ignore event))
+ (grab-remove window)
+ (gdk:pointer-ungrab)))
-;; (signal-connect window 'motion-notify-event
-;; #'(lambda (event)
-;; (declare (ignore event))
-;; (multiple-value-bind (win xp yp mask)
-;; (gdk:window-get-pointer root-window)
-;; (declare (ignore mask win) (fixnum xp yp))
-;; (widget-set-uposition
-;; window :x (- xp x-offset) :y (- yp y-offset)))
-;; t))
-;; (signal-connect window 'destroy destroy)))
+ (signal-connect window 'motion-notify-event
+ #'(lambda (event)
+ (declare (ignore event))
+ (multiple-value-bind (win xp yp mask)
+ (gdk:window-get-pointer root-window)
+ (declare (ignore mask win) (fixnum xp yp))
+ (window-move window (- xp x-offset) (- yp y-offset))))))
-;; (widget-show-all window)
-;; window))
-
-
-;; (let ((modeller nil)
-;; (sheets nil)
-;; (rings nil))
-;; (defun create-shapes ()
-;; (let ((root-window (gdk:get-root-window)))
-;; (if (not modeller)
-;; (setq
-;; modeller
-;; (shape-create-icon
-;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
-;; #'(lambda () (widget-destroyed modeller))))
-;; (widget-destroy modeller))
-
-;; (if (not sheets)
-;; (setq
-;; sheets
-;; (shape-create-icon
-;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
-;; #'(lambda () (widget-destroyed sheets))))
-;; (widget-destroy sheets))
-
-;; (if (not rings)
-;; (setq
-;; rings
-;; (shape-create-icon
-;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
-;; #'(lambda () (widget-destroyed rings))))
-;; (widget-destroy rings)))))
+ (window-move window x y)
+ (widget-show-all window)
+ window))
+
+
+(let ((modeller nil)
+ (sheets nil)
+ (rings nil))
+ (defun create-shapes ()
+ (let ((root-window (gdk:get-root-window)))
+ (if (not modeller)
+ (setq
+ modeller
+ (create-shape-icon
+ "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
+ #'(lambda () (setq modeller nil))))
+ (widget-destroy modeller))
+
+ (if (not sheets)
+ (setq
+ sheets
+ (create-shape-icon
+ "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
+ #'(lambda () (setq sheets nil))))
+ (widget-destroy sheets))
+
+ (if (not rings)
+ (setq
+ rings
+ (create-shape-icon
+ "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
+ #'(lambda () (setq rings nil))))
+ (widget-destroy rings)))))
:label label :xalign 0.0 :yalign 0.5)
:child (make-instance 'spin-button
:adjustment adjustment :wrap t))))
- (make-instance 'frame
- :label "Not accelerated" :parent main
- :child (make-instance 'h-box
- :border-width 10
- :child-args '(:padding 5)
- :child (create-date-spinner "Day : "
- (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
- :child (create-date-spinner "Month : "
- (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
- :child (create-date-spinner "Year : "
- (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
+ (multiple-value-bind (sec min hour date month year day daylight-p zone)
+ (get-decoded-time)
+ (declare (ignore sec min hour day daylight-p zone))
+ (make-instance 'frame
+ :label "Not accelerated" :parent main
+ :child (make-instance 'h-box
+ :border-width 10
+ :child-args '(:padding 5)
+ :child (create-date-spinner "Day : "
+ (adjustment-new date 1 31 1 5 0) :out)
+ :child (create-date-spinner "Month : "
+ (adjustment-new month 1 12 1 5 0) :etched-in)
+ :child (create-date-spinner "Year : "
+ (adjustment-new year 0 2100 1 100 0) :in)))))
(let ((spinner1 (make-instance 'spin-button
:adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
(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"))))
+ :action (make-instance 'toggle-action
+ :name "Bold" :stock-id "gtk-bold" :label "Bold"
+ :accelerator "<control>B" :tooltip "Bold"
+ :callback (create-toggle-callback "Bold"))
+ :action (make-instance 'toggle-action
+ :name "Italic" :stock-id "gtk-italic" :label "Italic"
+ :accelerator "<control>I" :tooltip "Italic"
+ :callback (create-toggle-callback "Italic"))
+ :action (make-instance 'toggle-action
+ :name "Underline" :stock-id "gtk-underline"
+ :label "Underline" :accelerator "<control>U"
+ :tooltip "Underline"
+ :callback (create-toggle-callback "Underline"))))
+ (ui (make-instance 'ui-manager
+ :action-group actions
+ :ui '((:toolbar "ToolBar"
+ (:toolitem "Bold")
+ (:toolitem "Italic")
+ (:toolitem "Underline"))))))
;; Callback to activate/deactivate toolbar buttons when cursor
;; is moved
(container-add window (create-toolbar window)))
+;;; Handle box
+
+(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")))
+
;;; Tooltips test
(:toolbar "ToolBar"
(:toolitem "Open")
(:toolitem "Quit")
- (:separator "Sep1")
+ :separator
(:toolitem "Logo"))))
(define-toplevel create-ui-manager (window "UI Manager")
- (let ((actions
- (make-instance 'action-group
- :name "Actions"
- :action (create-action "FileMenu" nil "_File")
- :action (create-action "PreferencesMenu" nil "_Preferences")
- :action (create-action "ColorMenu" nil "_Color")
- :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" #'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" (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)
- :actions (create-radio-actions
- '(("Red" nil "_Red" "<control>R" "Blood")
- ("Green" nil "_Green" "<control>G" "Grass")
- ("Blue" nil "_Blue" "<control>B" "Sky"))
- "Green")
- :actions (create-radio-actions
- '(("Square" nil "_Square" "<control>S" "Square")
- ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
- ("Oval" nil "_Oval" "<control>O" "Egg")))))
- (ui (make-instance 'ui-manager)))
-
- (ui-manager-insert-action-group ui actions)
+ (let ((ui (make-instance 'ui-manager)))
+ (window-add-accel-group window (ui-manager-accel-group ui))
+ (ui-manager-insert-action-group ui
+ (make-instance 'action-group :name "Actions"
+ :action (make-instance 'action :name "FileMenu" :label "_File")
+ :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
+ :action (make-instance 'action :name "ColorMenu" :label "_Color")
+ :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
+ :action (make-instance 'action :name "HelpMenu" :label "_Help")
+ :action (make-instance 'action
+ :name "New" :stock-id "gtk-new" :label "_New"
+ :accelerator "<control>N" :tooltip "Create a new file")
+ :action (make-instance 'action
+ :name "Open" :stock-id "gtk-open" :label "_Open"
+ :accelerator "<control>O" :tooltip "Open a file"
+ :callback #'create-file-chooser)
+ :action (make-instance 'action
+ :name "Save" :stock-id "gtk-save" :label "_Save"
+ :accelerator "<control>S" :tooltip "Save current file")
+ :action (make-instance 'action
+ :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
+ :tooltip "Save to a file")
+ :action (make-instance 'action
+ :name "Quit" :stock-id "gtk-quit" :label "_Quit"
+ :accelerator "<control>Q" :tooltip "Quit"
+ :callback (list #'widget-destroy :object window))
+ :action (make-instance 'action
+ :name "About" :label "_About"
+ :accelerator "<control>A" :tooltip "About")
+ :action (make-instance 'action
+ :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
+ :action (make-instance 'toggle-action
+ :name "Bold" :stock-id "gtk-bold" :label "_Bold"
+ :accelerator "<control>B" :tooltip "Bold" :active t)
+ :actions (make-radio-group 'radio-action
+ '((:name "Red" :value :red :label "_Red"
+ :accelerator "<control>R" :tooltip "Blood")
+ (:name "Green" :value :green :label "_Green"
+ :accelerator "<control>G" :tooltip "Grass" :active t)
+ (:name "Blue" :value :blue :label "_Blue"
+ :accelerator "<control>B" :tooltip "Sky"))
+ #'(lambda (active) (print active)))
+ :actions (make-radio-group 'radio-action
+ '((:name "Square" :value :square :label "_Square"
+ :accelerator "<control>S" :tooltip "Square")
+ (:name "Rectangle" :value :rectangle :label "_Rectangle"
+ :accelerator "<control>R" :tooltip "Rectangle")
+ (:name "Oval" :value :oval :label "_Oval"
+ :accelerator "<control>O" :tooltip "Egg"))
+ #'(lambda (active) (print active)))))
+
(ui-manager-add-ui ui *ui-description*)
- (window-add-accel-group window (ui-manager-accel-group ui))
-
(make-instance 'v-box
:parent window
:child (list
(ui-manager-get-widget ui "/ToolBar")
:expand nil :fill nil)
:child (make-instance 'label
- :label "Type <alt> to start"
+ :label "Type Ctrl+Q to quit"
:xalign 0.5 :yalign 0.5
:width-request 200 :height-request 200))))
;; ("event watcher")
("enxpander" create-expander)
("file chooser" create-file-chooser)
-;; ("font selection")
+ ("font selection" create-font-selection)
("handle box" create-handle-box)
+#+gtk2.6 ("icon view" create-icon-view)
("image" create-image)
("labels" create-labels)
("layout" create-layout)
;; ("saved position")
("scrolled windows" create-scrolled-windows)
("size group" create-size-group)
-;; ("shapes" create-shapes)
+ ("shapes" create-shapes)
("spinbutton" create-spins)
("statusbar" create-statusbar)
("test idle" create-idle-test)
:child-args '(:expand nil)
:child (list (make-instance 'label :label (gtk-version)) :fill nil)
:child (list (make-instance 'label :label "clg CVS version") :fill nil)
+ :child (list (make-instance 'label
+ :label #-cmu(format nil "~A (~A)"
+ (lisp-implementation-type)
+ (lisp-implementation-version))
+ ;; The version string in CMUCL is far too long
+ #+cmu(lisp-implementation-type))
+ :fill nil)
:child (list scrolled-window :expand t)
:child (make-instance 'h-separator)
:child (make-instance 'v-box
~mdw / clg / blobdiff