X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/842e5ffe2acf8474415544a32657c5948d72a2c4..ac776134ded8cae7be1b80aaad8b63eff2f456d4:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 7fe0786..970f311 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -1,37 +1,53 @@ -;; 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.16 2005-01-12 14:03:04 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)) (defun ,name () (unless ,window - (setq ,window (apply #'make-instance 'window :title ,title ',initargs)) + (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t)) (signal-connect ,window 'destroy #'(lambda () (setq ,window nil))) ,@body) - (if (not (widget-visible-p ,window)) - (widget-show-all ,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) @@ -40,13 +56,14 @@ (defmacro define-dialog (name (dialog title &optional (class 'dialog) `(let ((,dialog nil)) (defun ,name () (unless ,dialog - (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs)) + (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t)) (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) @@ -185,7 +202,7 @@ (defun create-bbox-in-frame (class frame-label spacing width height layout) (define-toplevel create-button-box (window "Button Boxes") (make-instance 'v-box - :parent window :border-width 10 :spacing 10 :show-all t + :parent window :border-width 10 :spacing 10 :child (make-instance 'frame :label "Horizontal Button Boxes" :child (make-instance 'v-box @@ -234,15 +251,14 @@ (define-simple-dialog create-buttons (dialog "Buttons") (widget-hide button+1) (widget-show button+1)))) (table-attach table button column (1+ column) row (1+ row) - :options '(:expand :fill))))) - (widget-show-all table))) + :options '(:expand :fill))))))) ;; Calenadar (define-simple-dialog create-calendar (dialog "Calendar") (make-instance 'v-box - :parent dialog :border-width 10 :show-all t + :parent dialog :border-width 10 :child (make-instance 'calendar))) @@ -250,7 +266,7 @@ (define-simple-dialog create-calendar (dialog "Calendar") (define-simple-dialog create-check-buttons (dialog "Check Buttons") (make-instance 'v-box - :border-width 10 :spacing 10 :parent dialog :show-all t + :border-width 10 :spacing 10 :parent dialog :children (loop for n from 1 to 3 collect (make-instance 'check-button @@ -262,25 +278,22 @@ (define-simple-dialog create-check-buttons (dialog "Check Buttons") (define-dialog create-color-selection (dialog "Color selection dialog" 'color-selection-dialog - :allow-grow nil :allow-shrink nil) - (with-slots (action-area colorsel) dialog -;; This seg faults for some unknown reason -;; (let ((button (make-instance 'check-button :label "Show Palette"))) -;; (dialog-add-action-widget dialog button -;; #'(lambda () -;; (setf -;; (color-selection-has-palette-p colorsel) -;; (toggle-button-active-p button))))) - - (container-add action-area - (create-check-button "Show Opacity" - #'(lambda (state) - (setf (color-selection-has-opacity-control-p colorsel) state)))) - - (container-add action-area - (create-check-button "Show Palette" - #'(lambda (state) - (setf (color-selection-has-palette-p colorsel) state)))) + :allow-grow nil :allow-shrink nil + :show-children nil) + (with-slots (colorsel) dialog + (let ((button (make-instance 'check-button :label "Show Opacity"))) + (dialog-add-action-widget dialog button + #'(lambda () + (setf + (color-selection-has-opacity-control-p colorsel) + (toggle-button-active-p button))))) + + (let ((button (make-instance 'check-button :label "Show Palette"))) + (dialog-add-action-widget dialog button + #'(lambda () + (setf + (color-selection-has-palette-p colorsel) + (toggle-button-active-p button))))) (signal-connect dialog :ok #'(lambda () @@ -327,11 +340,11 @@ (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 - :events '(:exposure-mask :button-press-mask))) + :events '(:exposure :button-press))) (label (make-instance 'label :label "XXX"))) (signal-connect drawing-area 'expose-event #'cursor-expose :object t) @@ -339,15 +352,15 @@ (define-simple-dialog create-cursors (dialog "Cursors") (signal-connect drawing-area 'button-press-event #'(lambda (event) (case (gdk:event-button event) - (1 (spin-button-spin spinner :step-forward 0.0)) - (3 (spin-button-spin spinner :step-backward 0.0))) + (1 (spin-button-spin spinner :step-forward)) + (3 (spin-button-spin spinner :step-backward))) t)) (signal-connect drawing-area 'scroll-event #'(lambda (event) (case (gdk:event-direction event) - (:up (spin-button-spin spinner :step-forward 0.0)) - (:down (spin-button-spin spinner :step-backward 0.0))) + (:up (spin-button-spin spinner :step-forward)) + (:down (spin-button-spin spinner :step-backward))) t)) (signal-connect spinner 'changed @@ -355,7 +368,7 @@ (define-simple-dialog create-cursors (dialog "Cursors") (set-cursor spinner drawing-area label))) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 5 :show-all t + :parent dialog :border-width 10 :spacing 5 :child (list (make-instance 'h-box :border-width 5 @@ -365,7 +378,6 @@ (define-simple-dialog create-cursors (dialog "Cursors") :child spinner) :expand nil) :child (make-instance 'frame -; :shadow-type :etched-in :label "Cursor Area" :label-xalign 0.5 :border-width 10 :child drawing-area) :child (list label :expand nil)) @@ -440,15 +452,14 @@ (define-simple-dialog create-entry (dialog "Entry") (create-check-button "Editable" 'editable) (create-check-button "Visible" 'visibility) - (create-check-button "Sensitive" 'sensitive))) - (widget-show-all main))) + (create-check-button "Sensitive" 'sensitive))))) ;; Expander (define-simple-dialog create-expander (dialog "Expander" :resizable nil) (make-instance 'v-box - :parent dialog :spacing 5 :border-width 5 :show-all t + :parent dialog :spacing 5 :border-width 5 :child (create-label "Expander demo. Click on the triangle for details.") :child (make-instance 'expander :label "Details" @@ -458,6 +469,12 @@ (define-simple-dialog create-expander (dialog "Expander" :resizable nil) ;; 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 () @@ -467,32 +484,134 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) (widget-destroy dialog)))) +;; Font selection dialog + +(define-toplevel create-font-selection (window "Font Button" :resizable nil) + (make-instance 'h-box + :parent window :spacing 8 :border-width 8 + :child (make-instance 'label :label "Pick a font") + :child (make-instance 'font-button + :use-font t :title "Font Selection Dialog"))) + + +;;; 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)))))) -;;; 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"))) ;;; 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)) @@ -539,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 "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____"))))) @@ -571,9 +691,8 @@ (define-toplevel create-layout (window "Layout" :default-width 200 :default-height 200) (let ((layout (make-instance 'layout :parent (make-instance 'scrolled-window :parent window) - :width 1600 :height 128000 :events '(:exposure-mask) - :signal (list 'expose-event #'layout-expose :object t) - ))) + :width 1600 :height 128000 :events '(:exposure) + :signal (list 'expose-event #'layout-expose :object t)))) (with-slots (hadjustment vadjustment) layout (setf @@ -583,18 +702,22 @@ (define-toplevel create-layout (window "Layout" :default-width 200 (dotimes (i 16) (dotimes (j 16) (let ((text (format nil "Button ~D, ~D" i j))) - (make-instance (if (not (zerop (mod (+ i j) 2))) - 'button - 'label) - :label text :parent (list layout :x (* j 100) :y (* i 100)))))) + (layout-put layout + (make-instance (if (not (zerop (mod (+ i j) 2))) + 'button + 'label) + :label text :visible t) + (* j 100) (* i 100))))) (loop for i from 16 below 1280 do (let ((text (format nil "Button ~D, ~D" i 0))) - (make-instance (if (not (zerop (mod i 2))) - 'button - 'label) - :label text :parent (list layout :x 0 :y (* i 100))))))) + (layout-put layout + (make-instance (if (not (zerop (mod i 2))) + 'button + 'label) + :label text :visible t) + 0 (* i 100)))))) @@ -602,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)))) @@ -632,7 +755,7 @@ (define-simple-dialog create-list (dialog "List" :default-height 400) (tree-view-append-column tree column)) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :child (list (make-instance 'h-box :spacing 10 @@ -791,12 +914,12 @@ (defun create-notebook-page (notebook page-num book-closed) :signal (list 'clicked #'(lambda () (widget-hide page))))) (let ((label-box (make-instance 'h-box - :show-all t + :show-children t :child-args '(:expand nil) :child (make-instance 'image :pixbuf book-closed) :child (make-instance 'label :label title))) (menu-box (make-instance 'h-box - :show-all t + :show-children t :child-args '(:expand nil) :child (make-instance 'image :pixbuf book-closed) :child (make-instance 'label :label title)))) @@ -984,7 +1107,7 @@ (define-simple-dialog create-progress-bar (dialog "Progress Bar") t)))) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :child progress :child activity-mode-button) @@ -996,7 +1119,7 @@ (define-simple-dialog create-progress-bar (dialog "Progress Bar") (define-simple-dialog create-radio-buttons (dialog "Radio buttons") (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :children (make-radio-group 'radio-button '((:label "button1") (:label "button2") (:label "button3")) nil))) @@ -1007,7 +1130,7 @@ (define-simple-dialog create-radio-buttons (dialog "Radio buttons") (define-simple-dialog create-range-controls (dialog "Range controls") (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0))) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :child (make-instance 'h-scale :width-request 150 :adjustment adjustment :inverted t :update-policy :delayed :digits 1 :draw-value t) @@ -1042,13 +1165,7 @@ (define-simple-dialog create-reparent (dialog "Reparent") (define-toplevel create-rulers (window "Rulers" :default-width 300 :default-height 300 -;; :events '(:pointer-motion-mask -;; :pointer-motion-hint-mask) - ) - (setf - (widget-events window) - '(:pointer-motion-mask :pointer-motion-hint-mask)) - + :events '(:pointer-motion :pointer-motion-hint)) (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)) (h-ruler (make-instance 'h-ruler :metric :centimeters :lower 100.0d0 :upper 0.0d0 @@ -1111,7 +1228,7 @@ (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil) (make-instance 'frame :label label :child table)))) (make-instance 'v-box - :parent dialog :border-width 5 :spacing 5 :show-all t + :parent dialog :border-width 5 :spacing 5 :child (create-frame "Color Options" '(("Foreground" "Red" "Green" "Blue") ("Background" "Red" "Green" "Blue"))) @@ -1128,86 +1245,79 @@ (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil) ;;; Shapes -;; (defun shape-create-icon (xpm-file x y px py type root-window destroy) -;; (let* ((window -;; (make-instance 'window -;; :type type :x x :y y -;; :events '(:button-motion :pointer-motion-hint :button-press))) -;; (fixed -;; (make-instance 'fixed -;; :parent window :width 100 :height 100))) +(defun create-shape-icon (xpm-file x y px py type root-window destroy) + (let ((window + (make-instance 'window + :type type :default-width 100 :default-height 100 + :events '(:button-motion :pointer-motion-hint :button-press) + :signal (list 'destroy destroy)))) -;; (widget-realize window) -;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file) -;; (let ((pixmap (pixmap-new source mask)) -;; (x-offset 0) -;; (y-offset 0)) -;; (declare (fixnum x-offset y-offset)) -;; (fixed-put fixed pixmap px py) -;; (widget-shape-combine-mask window mask px py) + (widget-realize window) + (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file) + (let ((fixed (make-instance 'fixed :parent window))) + (fixed-put fixed (create-image-widget source mask) px py)) + (widget-shape-combine-mask window mask px py)) -;; (signal-connect window 'button-press-event -;; #'(lambda (event) -;; (when (typep event 'gdk:button-press-event) -;; (setq x-offset (truncate (gdk:event-x event))) -;; (setq y-offset (truncate (gdk:event-y event))) -;; (grab-add window) -;; (gdk:pointer-grab -;; (widget-window window) t -;; '(:button-release :button-motion :pointer-motion-hint) -;; nil nil 0)) -;; t)) - -;; (signal-connect window 'button-release-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (grab-remove window) -;; (gdk:pointer-ungrab 0) -;; t)) + (let ((x-offset 0) + (y-offset 0)) + (declare (fixnum x-offset y-offset)) + (signal-connect window 'button-press-event + #'(lambda (event) + (when (typep event 'gdk:button-press-event) + (setq x-offset (truncate (gdk:event-x event))) + (setq y-offset (truncate (gdk:event-y event))) + (grab-add window) + (gdk:pointer-grab (widget-window window) + :events '(:button-release :button-motion :pointer-motion-hint) + :owner-events t)))) + + (signal-connect window 'button-release-event + #'(lambda (event) + (declare (ignore event)) + (grab-remove window) + (gdk:pointer-ungrab))) -;; (signal-connect window 'motion-notify-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (multiple-value-bind (win xp yp mask) -;; (gdk:window-get-pointer root-window) -;; (declare (ignore mask win) (fixnum xp yp)) -;; (widget-set-uposition -;; window :x (- xp x-offset) :y (- yp y-offset))) -;; t)) -;; (signal-connect window 'destroy destroy))) + (signal-connect window 'motion-notify-event + #'(lambda (event) + (declare (ignore event)) + (multiple-value-bind (win xp yp mask) + (gdk:window-get-pointer root-window) + (declare (ignore mask win) (fixnum xp yp)) + (window-move window (- xp x-offset) (- yp y-offset)))))) -;; (widget-show-all window) -;; window)) - - -;; (let ((modeller nil) -;; (sheets nil) -;; (rings nil)) -;; (defun create-shapes () -;; (let ((root-window (gdk:get-root-window))) -;; (if (not modeller) -;; (setq -;; modeller -;; (shape-create-icon -;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window -;; #'(lambda () (widget-destroyed modeller)))) -;; (widget-destroy modeller)) - -;; (if (not sheets) -;; (setq -;; sheets -;; (shape-create-icon -;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window -;; #'(lambda () (widget-destroyed sheets)))) -;; (widget-destroy sheets)) - -;; (if (not rings) -;; (setq -;; rings -;; (shape-create-icon -;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window -;; #'(lambda () (widget-destroyed rings)))) -;; (widget-destroy rings))))) + (window-move window x y) + (widget-show-all window) + window)) + + +(let ((modeller nil) + (sheets nil) + (rings nil)) + (defun create-shapes () + (let ((root-window (gdk:get-root-window))) + (if (not modeller) + (setq + modeller + (create-shape-icon + "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window + #'(lambda () (setq modeller nil)))) + (widget-destroy modeller)) + + (if (not sheets) + (setq + sheets + (create-shape-icon + "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window + #'(lambda () (setq sheets nil)))) + (widget-destroy sheets)) + + (if (not rings) + (setq + rings + (create-shape-icon + "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window + #'(lambda () (setq rings nil)))) + (widget-destroy rings))))) @@ -1225,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) @@ -1360,7 +1473,7 @@ (define-simple-dialog create-idle-test (dialog "Idle Test") #'(lambda () (when idle (idle-remove idle)))) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :child label :child (make-instance 'frame :label "Label Container" :border-width 5 @@ -1442,29 +1555,32 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400 (setq active-tags (delete tag active-tags))) (multiple-value-bind (non-zero-p start end) (text-buffer-get-selection-bounds buffer) + (declare (ignore non-zero-p)) (if active (text-buffer-apply-tag buffer tag start end) (text-buffer-remove-tag buffer tag start end)))))))) (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 @@ -1507,7 +1623,7 @@ (define-simple-dialog create-text (dialog "Text" :default-width 400 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button") (make-instance 'v-box - :border-width 10 :spacing 10 :parent dialog :show-all t + :border-width 10 :spacing 10 :parent dialog :children (loop for n from 1 to 3 collect (make-instance 'toggle-button @@ -1607,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 @@ -1617,7 +1755,7 @@ (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200) (tooltips-set-tip tooltips button tip-text tip-private) button))) (make-instance 'v-box - :parent dialog :border-width 10 :spacing 10 :show-all t + :parent dialog :border-width 10 :spacing 10 :child (create-button "button1" "This is button 1" "ContextHelp/button/1") :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2"))))) @@ -1648,44 +1786,65 @@ (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 :show-all t + :parent window :child (list (ui-manager-get-widget ui "/MenuBar") :expand nil :fill nil) @@ -1693,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)))) @@ -1718,8 +1877,9 @@ (defun create-main-window () ;; ("event watcher") ("enxpander" create-expander) ("file chooser" create-file-chooser) -;; ("font selection") + ("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) @@ -1737,7 +1897,7 @@ (defun create-main-window () ;; ("saved position") ("scrolled windows" create-scrolled-windows) ("size group" create-size-group) -;; ("shapes" create-shapes) + ("shapes" create-shapes) ("spinbutton" create-spins) ("statusbar" create-statusbar) ("test idle" create-idle-test) @@ -1776,6 +1936,13 @@ (defun create-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 #-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