-;; 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-2006 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.21 2005-02-27 13:28:19 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.41 2007-07-12 09:18:30 espen Exp $
+
+#+sbcl(require :gtk)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
+
+(defpackage "TESTGTK"
+ (:use "COMMON-LISP" "CLG"))
+
+(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)
(signal-connect dialog :cancel #'widget-destroy :object t)))
-;;; Cursors
+;;; Cursors (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
(defun clamp (n min-val max-val)
(declare (number n min-val max-val))
(defun set-cursor (spinner drawing-area label)
(let ((cursor
- (glib:int-enum
+ (gffi: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)))
+ (widget-set-cursor drawing-area cursor)))
(defun cursor-expose (drawing-area event)
(declare (ignore event))
(let ((spinner (make-instance 'spin-button
:adjustment (adjustment-new
0 0
- (1- (enum-int :last-cursor 'gdk:cursor-type))
+ (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
2 10 0)))
(drawing-area (make-instance 'drawing-area
:width-request 80 :height-request 80
;; 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 ()
:use-font t :title "Font Selection Dialog")))
-;;; Handle box
+;;; Icon View
+
+#+(or cmu sbcl)
+(defun get-directory-listing (directory)
+ (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
+ collect (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 filename directory-p)))
+ #+cmu(unix:close-dir dir)
+ #+sbcl(sb-posix:closedir dir))))
+
+#+clisp
+(defun get-directory-listing (directory)
+ (nconc
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring (first entry))))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
+ (directory (format nil "~A*" directory) :full t))
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring entry)))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
+
+ (directory (format nil "~A*/" directory)))))
+
+
+#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+(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 :ok #'widget-destroy :object t))
+ (return-from load-pixbufs nil))))
+ t)
+
+ (defun fill-store (store directory)
+ (list-store-clear store)
+ (loop
+ for (filename directory-p) in (get-directory-listing directory)
+ unless (or (string= filename ".") (string= filename ".."))
+ do (list-store-insert store 0
+ (vector
+ filename
+ (if directory-p folder-pixbuf file-pixbuf)
+ directory-p))))
+
+ (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))))))
-(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))
(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
(flet ((create-label-in-frame (frame-label label-text &rest args)
- (list
- (make-instance 'frame
- :label frame-label
- :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
- :fill nil :expand nil)))
+ (make-instance 'frame
+ :label frame-label
+ :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
(make-instance 'h-box
:spacing 5 :parent window
:child-args '(:fill nil :expand nil)
:child (make-instance 'v-box
- :spacing 5
+ :spacing 5 :child-args '(:fill nil :expand nil)
:child (create-label-in-frame "Normal Label" "This is a Normal label")
:child (create-label-in-frame "Multi-line Label"
"This is a Multi-line label.
Third line"
:justify :right))
:child (make-instance 'v-box
- :spacing 5
+ :spacing 5 :child-args '(:fill nil :expand nil)
:child (create-label-in-frame "Line wrapped label"
"This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
:child (create-label-in-frame "Underlined label"
"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 "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
-;;; Layout
+;;; Layout (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
(defun layout-expose (layout event)
(when (eq (gdk:event-window event) (layout-bin-window 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))))
(let ((column (make-instance 'tree-view-column :title "Column 1"))
(cell (make-instance 'cell-renderer-text)))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :foo))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
(tree-view-append-column tree column))
(let ((column (make-instance 'tree-view-column :title "Column 2"))
(cell (make-instance 'cell-renderer-text :background "orange")))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :bar))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
(tree-view-append-column tree column))
(let ((column (make-instance 'tree-view-column :title "Column 3"))
(cell (make-instance 'cell-renderer-text)))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :baz))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
(tree-view-append-column tree column))
(make-instance 'v-box
:label "Hide page"
:signal (list 'clicked #'(lambda () (widget-hide page)))))
+
(let ((label-box (make-instance 'h-box
:show-children t
:child-args '(:expand nil)
:child (make-instance 'image :pixbuf book-closed)
:child (make-instance 'label :label title))))
- (widget-show-all page)
(notebook-append notebook page label-box menu-box))))
-
(define-simple-dialog create-notebook (dialog "Notebook")
(let ((main (make-instance 'v-box :parent dialog)))
(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
+ (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 pixbuf)
(setf
(image-pixbuf
:spacing 5 :border-width 10
:parent (list main :expand nil)
:child (make-instance 'button
- :label "prev"
+ :label "Prev"
:signal (list 'clicked #'notebook-prev-page :object notebook))
:child (make-instance 'button
- :label "next"
+ :label "Next"
:signal (list 'clicked #'notebook-next-page :object notebook))
:child (make-instance 'button
- :label "rotate"
+ :label "Rotate"
:signal (let ((tab-pos 0))
(list 'clicked
#'(lambda ()
(widget-show-all main)))
+
;;; Panes
(defun toggle-resize (child)
(grab-add window)
(gdk:pointer-grab (widget-window window)
:events '(:button-release :button-motion :pointer-motion-hint)
- :owner-events t :time event))))
+ :owner-events t))))
(signal-connect window 'button-release-event
#'(lambda (event)
+ (declare (ignore event))
(grab-remove window)
- (gdk:pointer-ungrab event)))
+ (gdk:pointer-ungrab)))
(signal-connect window 'motion-notify-event
#'(lambda (event)
: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
:after t)
(container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
- (container-add dialog text-view)))))
+ (container-add dialog text-view)
+
+ (let ((position (make-instance 'label :visible t)))
+ (flet ((update-position (line column)
+ (setf
+ (label-label position)
+ (format nil "Cursor Position: ~d,~d" (1+ line) column))))
+ (update-position 0 0)
+
+ ;; Callback to display current position when cursor is moved
+ (signal-connect buffer 'mark-set
+ #'(lambda (iter mark)
+ (when (and
+ (slot-boundp mark 'name)
+ (string= (text-mark-name mark) "insert"))
+ (update-position
+ (text-iter-line iter) (text-iter-line-offset iter)))))
+
+ ;; Callback to display current position after the
+ ;; buffer has been modified
+ (signal-connect buffer 'changed
+ #'(lambda ()
+ (let ((iter (text-buffer-get-iter-at-insert buffer)))
+ (update-position
+ (text-iter-line iter) (text-iter-line-offset iter))))
+ :after t))
+
+ (container-add dialog position :expand nil))))))
;;; Toggle buttons
(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))))
;;; Main window
-(defun create-main-window ()
-;; (rc-parse "clg:examples;testgtkrc2")
-;; (rc-parse "clg:examples;testgtkrc")
-
+(defun create-main-window (&optional display)
(let* ((button-specs
'(("button box" create-button-box)
("buttons" create-buttons)
("color selection" create-color-selection)
("cursors" create-cursors)
("dialog" create-dialog)
-;; ; ("dnd")
("entry" create-entry)
-;; ("event watcher")
("enxpander" create-expander)
("file chooser" create-file-chooser)
("font selection" create-font-selection)
("handle box" create-handle-box)
+ #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+ ("icon view" create-icon-view)
("image" create-image)
("labels" create-labels)
("layout" create-layout)
("spinbutton" create-spins)
("statusbar" create-statusbar)
("test idle" create-idle-test)
-;; ("test mainloop")
-;; ("test scrolling")
-;; ("test selection")
("test timeout" create-timeout-test)
("text" create-text)
("toggle buttons" create-toggle-buttons)
("toolbar" create-toolbar-window)
("tooltips" create-tooltips)
-;; ("tree" #|create-tree|#)
- ("UI manager" create-ui-manager)
-))
- (main-window (make-instance 'window
- :title "testgtk.lisp" :name "main_window"
- :default-width 200 :default-height 400
- :allow-grow t :allow-shrink nil))
- (scrolled-window (make-instance 'scrolled-window
- :hscrollbar-policy :automatic
- :vscrollbar-policy :automatic
- :border-width 10))
- (close-button (make-instance 'button
- :label "close" :can-default t
- :signal (list 'clicked #'widget-destroy
- :object main-window))))
+ ("UI manager" create-ui-manager)))
+
+ (main-window (make-instance 'window
+ :display display
+ :title "testgtk.lisp" :name "main_window"
+ :default-width 200 :default-height 400
+ :allow-grow t :allow-shrink nil))
+ (scrolled-window (make-instance 'scrolled-window
+ :hscrollbar-policy :automatic
+ :vscrollbar-policy :automatic
+ :border-width 10))
+ (close-button (make-instance 'button
+ :stock "gtk-close" :can-default t
+ :signal (list 'clicked #'widget-destroy :object main-window))))
(let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
(setf
:parent main-window
: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 (clg-version)) :fill nil)
+ :child (list (make-instance 'label
+ :label #-cmu
+ (format nil "~A (~A)"
+ (lisp-implementation-type)
+ #-clisp
+ (lisp-implementation-version)
+ #+clisp
+ (let ((version (lisp-implementation-version)))
+ (subseq version 0 (position #\sp 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
(let ((content-box
(make-instance 'v-box
:focus-vadjustment (scrolled-window-vadjustment scrolled-window)
- :children (mapcar #'(lambda (spec)
+ :children (mapcar #'(lambda (spec)
(apply #'create-button spec))
- button-specs))))
+ button-specs))))
(scrolled-window-add-with-viewport scrolled-window content-box))
(widget-grab-focus close-button)
main-window))
(clg-init)
-(create-main-window)
+(within-main-loop (create-main-window))
~mdw / clg / blobdiff