X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/c2ef984cfe5918fbac85bfd7422ae4d988ec6043..ac776134ded8cae7be1b80aaad8b63eff2f456d4:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index e5b7961..970f311 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -1,25 +1,40 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2005 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 1999-2005 Espen S. Johnsen ;; -;; 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.23 2005-02-27 19:15:07 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)) @@ -29,9 +44,10 @@ (defun ,name () (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) @@ -44,9 +60,10 @@ (defun ,name () (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) @@ -323,7 +340,7 @@ (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)) + (1- (glib:enum-int :last-cursor 'gdk:cursor-type)) 2 10 0))) (drawing-area (make-instance 'drawing-area :width-request 80 :height-request 80 @@ -477,31 +494,124 @@ (define-toplevel create-font-selection (window "Font Button" :resizable nil) :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 "Failed to load an image" + :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)) @@ -548,8 +658,9 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil) :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 "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____"))))) @@ -614,7 +725,7 @@ (define-toplevel create-layout (window "Layout" :default-width 200 (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)))) @@ -1158,12 +1269,13 @@ (defun create-shape-icon (xpm-file x y px py type root-window destroy) (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) @@ -1223,17 +1335,20 @@ (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil) :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) @@ -1447,23 +1562,25 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400 (let* ((actions (make-instance 'action-group - :action (create-toggle-action - "Bold" "gtk-bold" "Bold" "B" "Bold" nil - (create-toggle-callback "Bold")) - :action (create-toggle-action - "Italic" "gtk-italic" "Italic" "I" "Italic" nil - (create-toggle-callback "Italic")) - :action (create-toggle-action - "Underline" "gtk-underline" "Underline" "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 "B" :tooltip "Bold" + :callback (create-toggle-callback "Bold")) + :action (make-instance 'toggle-action + :name "Italic" :stock-id "gtk-italic" :label "Italic" + :accelerator "I" :tooltip "Italic" + :callback (create-toggle-callback "Italic")) + :action (make-instance 'toggle-action + :name "Underline" :stock-id "gtk-underline" + :label "Underline" :accelerator "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 @@ -1606,6 +1723,28 @@ (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil) (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 @@ -1647,42 +1786,63 @@ (defvar *ui-description* (: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" "N" "Create a new file") - :action (create-action "Open" "gtk-open" "_Open" "O" "Open a file" #'create-file-chooser) - :action (create-action "Save" "gtk-save" "_Save" "S" "Save current file") - :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file") - :action (create-action "Quit" "gtk-quit" "_Quit" "Q" "Quit" (list #'widget-destroy :object window)) - :action (create-action "About" nil "_About" "A" "About") - :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+") - :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "B" "Bold" t) - :actions (create-radio-actions - '(("Red" nil "_Red" "R" "Blood") - ("Green" nil "_Green" "G" "Grass") - ("Blue" nil "_Blue" "B" "Sky")) - "Green") - :actions (create-radio-actions - '(("Square" nil "_Square" "S" "Square") - ("Rectangle" nil "_Rectangle" "R" "Rectangle") - ("Oval" nil "_Oval" "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 "N" :tooltip "Create a new file") + :action (make-instance 'action + :name "Open" :stock-id "gtk-open" :label "_Open" + :accelerator "O" :tooltip "Open a file" + :callback #'create-file-chooser) + :action (make-instance 'action + :name "Save" :stock-id "gtk-save" :label "_Save" + :accelerator "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 "Q" :tooltip "Quit" + :callback (list #'widget-destroy :object window)) + :action (make-instance 'action + :name "About" :label "_About" + :accelerator "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 "B" :tooltip "Bold" :active t) + :actions (make-radio-group 'radio-action + '((:name "Red" :value :red :label "_Red" + :accelerator "R" :tooltip "Blood") + (:name "Green" :value :green :label "_Green" + :accelerator "G" :tooltip "Grass" :active t) + (:name "Blue" :value :blue :label "_Blue" + :accelerator "B" :tooltip "Sky")) + #'(lambda (active) (print active))) + :actions (make-radio-group 'radio-action + '((:name "Square" :value :square :label "_Square" + :accelerator "S" :tooltip "Square") + (:name "Rectangle" :value :rectangle :label "_Rectangle" + :accelerator "R" :tooltip "Rectangle") + (:name "Oval" :value :oval :label "_Oval" + :accelerator "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 @@ -1692,7 +1852,7 @@ (define-toplevel create-ui-manager (window "UI Manager") (ui-manager-get-widget ui "/ToolBar") :expand nil :fill nil) :child (make-instance 'label - :label "Type to start" + :label "Type Ctrl+Q to quit" :xalign 0.5 :yalign 0.5 :width-request 200 :height-request 200)))) @@ -1719,6 +1879,7 @@ (defun create-main-window () ("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)