-;; 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.22 2005/02/27 14:24:49 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.32 2005/04/25 21:45:05 espen Exp $
+
+#+sbcl(require :gtk)
+#+cmu(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
:use-font t :title "Font Selection Dialog")))
-;;; Handle box
+;;; 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))))))
-(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 "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
(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))))
(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
(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))))
("file chooser" create-file-chooser)
("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)
: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)
+ (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