X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/9706ddd7b4d93a327d83e2bb9e4dcf1de8675245..bd359292736503f7a7a934e2311f4e332af10a60:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index d30ccb9..1bc85c2 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -1,21 +1,35 @@ -;; 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.27 2005-04-18 10:39:32 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. + + +;; $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")) @@ -1255,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) @@ -1547,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 @@ -1769,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 @@ -1814,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)))) @@ -1897,7 +1935,7 @@ (defun create-main-window () :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)