-;; 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.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"))
(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)
(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
(: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))))
: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)
~mdw / clg / blobdiff