1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; Parts of this file are direct translations of code from 'testgtk.c'
24 ;; distributed with the Gtk+ library, and thus covered by the GNU
25 ;; Lesser General Public License and copyright Peter Mattis, Spencer
26 ;; Kimball, Josh MacDonald and others.
29 ;; $Id: testgtk.lisp,v 1.33 2006/02/13 16:05:29 espen Exp $
32 #+sbcl(require :sb-posix)
33 #+cmu(asdf:oos 'asdf:load-op :gtk)
36 (:use "COMMON-LISP" "GTK"))
38 (in-package "TESTGTK")
40 (defmacro define-toplevel (name (window title &rest initargs) &body body)
44 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
45 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
49 (if (not (widget-visible-p ,window))
51 (widget-hide ,window))))))
54 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
60 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
61 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
65 (if (not (widget-visible-p ,dialog))
67 (widget-hide ,dialog))))))
70 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
71 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
73 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
77 ;;; Pixmaps used in some of the tests
119 (defvar book-closed-xpm
144 (defvar mini-page-xpm
167 (defvar book-open-xpm
194 (defun create-bbox-in-frame (class frame-label spacing width height layout)
195 (declare (ignore width height))
196 (make-instance 'frame
198 :child (make-instance class
199 :border-width 5 :layout-style layout :spacing spacing
200 :child (make-instance 'button :stock "gtk-ok")
201 :child (make-instance 'button :stock "gtk-cancel")
202 :child (make-instance 'button :stock "gtk-help"))))
204 (define-toplevel create-button-box (window "Button Boxes")
205 (make-instance 'v-box
206 :parent window :border-width 10 :spacing 10
207 :child (make-instance 'frame
208 :label "Horizontal Button Boxes"
209 :child (make-instance 'v-box
210 :border-width 10 :spacing 10
213 (apply #'create-bbox-in-frame
215 '(("Spread" 40 85 20 :spread)
216 ("Edge" 40 85 20 :edge)
217 ("Start" 40 85 20 :start)
218 ("End" 40 85 20 :end)))))
219 :child (make-instance 'frame
220 :label "Vertical Button Boxes"
221 :child (make-instance 'h-box
222 :border-width 10 :spacing 10
225 (apply #'create-bbox-in-frame
227 '(("Spread" 30 85 20 :spread)
228 ("Edge" 30 85 20 :edge)
229 ("Start" 30 85 20 :start)
230 ("End" 30 85 20 :end)))))))
235 (define-simple-dialog create-buttons (dialog "Buttons")
236 (let ((table (make-instance 'table
237 :n-rows 3 :n-columns 3 :homogeneous nil
238 :row-spacing 5 :column-spacing 5 :border-width 10
242 collect (make-instance 'button
243 :label (format nil "button~D" (1+ n))))))
247 (let ((button (nth (+ (* 3 row) column) buttons))
248 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
249 (signal-connect button 'clicked
251 (if (widget-visible-p button+1)
252 (widget-hide button+1)
253 (widget-show button+1))))
254 (table-attach table button column (1+ column) row (1+ row)
255 :options '(:expand :fill)))))))
260 (define-simple-dialog create-calendar (dialog "Calendar")
261 (make-instance 'v-box
262 :parent dialog :border-width 10
263 :child (make-instance 'calendar)))
268 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
269 (make-instance 'v-box
270 :border-width 10 :spacing 10 :parent dialog
273 collect (make-instance 'check-button
274 :label (format nil "Button~D" n)))))
280 (define-dialog create-color-selection (dialog "Color selection dialog"
281 'color-selection-dialog
282 :allow-grow nil :allow-shrink nil
284 (with-slots (colorsel) dialog
285 (let ((button (make-instance 'check-button :label "Show Opacity")))
286 (dialog-add-action-widget dialog button
289 (color-selection-has-opacity-control-p colorsel)
290 (toggle-button-active-p button)))))
292 (let ((button (make-instance 'check-button :label "Show Palette")))
293 (dialog-add-action-widget dialog button
296 (color-selection-has-palette-p colorsel)
297 (toggle-button-active-p button)))))
299 (signal-connect dialog :ok
301 (let ((color (color-selection-current-color colorsel)))
302 (format t "Selected color: ~A~%" color)
303 (setf (color-selection-current-color colorsel) color)
304 (widget-hide dialog))))
306 (signal-connect dialog :cancel #'widget-destroy :object t)))
311 (defun clamp (n min-val max-val)
312 (declare (number n min-val max-val))
313 (max (min n max-val) min-val))
315 (defun set-cursor (spinner drawing-area label)
318 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
320 (setf (label-label label) (string-downcase cursor))
321 (setf (widget-cursor drawing-area) cursor)))
323 (defun cursor-expose (drawing-area event)
324 (declare (ignore event))
325 (multiple-value-bind (width height)
326 (widget-get-size-allocation drawing-area)
327 (let* ((window (widget-window drawing-area))
328 (style (widget-style drawing-area))
329 (white-gc (style-white-gc style))
330 (gray-gc (style-bg-gc style :normal))
331 (black-gc (style-black-gc style)))
332 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
333 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
335 (gdk:draw-rectangle window gray-gc t (floor width 3)
336 (floor height 3) (floor width 3)
340 (define-simple-dialog create-cursors (dialog "Cursors")
341 (let ((spinner (make-instance 'spin-button
342 :adjustment (adjustment-new
344 (1- (glib:enum-int :last-cursor 'gdk:cursor-type))
346 (drawing-area (make-instance 'drawing-area
347 :width-request 80 :height-request 80
348 :events '(:exposure :button-press)))
349 (label (make-instance 'label :label "XXX")))
351 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
353 (signal-connect drawing-area 'button-press-event
355 (case (gdk:event-button event)
356 (1 (spin-button-spin spinner :step-forward))
357 (3 (spin-button-spin spinner :step-backward)))
360 (signal-connect drawing-area 'scroll-event
362 (case (gdk:event-direction event)
363 (:up (spin-button-spin spinner :step-forward))
364 (:down (spin-button-spin spinner :step-backward)))
367 (signal-connect spinner 'changed
369 (set-cursor spinner drawing-area label)))
371 (make-instance 'v-box
372 :parent dialog :border-width 10 :spacing 5
374 (make-instance 'h-box
377 (make-instance 'label :label "Cursor Value : ")
381 :child (make-instance 'frame
382 :label "Cursor Area" :label-xalign 0.5 :border-width 10
384 :child (list label :expand nil))
386 (widget-realize drawing-area)
387 (set-cursor spinner drawing-area label)))
393 (defun create-dialog ()
395 (setq dialog (make-instance 'dialog
396 :title "Dialog" :default-width 200
398 :button (list "gtk-ok" #'widget-destroy :object t)
399 :signal (list 'destroy
401 (setq dialog nil)))))
403 (let ((label (make-instance 'label
404 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
406 (signal-connect dialog "Toggle"
408 (if (widget-visible-p label)
410 (widget-show label))))))
412 (if (widget-visible-p dialog)
414 (widget-show dialog))))
419 (define-simple-dialog create-entry (dialog "Entry")
420 (let ((main (make-instance 'v-box
421 :border-width 10 :spacing 10 :parent dialog)))
423 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
424 (editable-select-region entry 0 5) ; this has no effect when
426 ;; (editable-insert-text entry "great " 6)
427 ;; (editable-delete-text entry 6 12)
429 (let ((combo (make-instance 'combo-box-entry
434 "item3 item3 item3 item3"
435 "item4 item4 item4 item4 item4"
436 "item5 item5 item5 item5 item5 item5"
437 "item6 item6 item6 item6 item6"
438 "item7 item7 item7 item7"
441 (with-slots (child) combo
442 (setf (editable-text child) "hello world")
443 (editable-select-region child 0)))
445 (flet ((create-check-button (label slot)
446 (make-instance 'check-button
447 :label label :active t :parent main
448 :signal (list 'toggled
450 (setf (slot-value entry slot)
451 (toggle-button-active-p button)))
454 (create-check-button "Editable" 'editable)
455 (create-check-button "Visible" 'visibility)
456 (create-check-button "Sensitive" 'sensitive)))))
461 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
462 (make-instance 'v-box
463 :parent dialog :spacing 5 :border-width 5
464 :child (create-label "Expander demo. Click on the triangle for details.")
465 :child (make-instance 'expander
467 :child (create-label "Details can be shown or hidden."))))
470 ;; File chooser dialog
472 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
473 (file-chooser-add-filter dialog
474 (make-instance 'file-filter :name "All files" :pattern "*"))
475 (file-chooser-add-filter dialog
476 (make-instance 'file-filter :name "Common Lisp source code"
477 :patterns '("*.lisp" "*.lsp")))
479 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
480 (dialog-add-button dialog "gtk-ok"
482 (if (slot-boundp dialog 'filename)
483 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
484 (write-line "No files selected"))
485 (widget-destroy dialog))))
488 ;; Font selection dialog
490 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
491 (make-instance 'h-box
492 :parent window :spacing 8 :border-width 8
493 :child (make-instance 'label :label "Pick a font")
494 :child (make-instance 'font-button
495 :use-font t :title "Font Selection Dialog")))
501 (let ((file-pixbuf nil)
503 (defun load-pixbufs ()
507 file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
508 folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
509 (glib:glib-error (condition)
510 (make-instance 'message-dialog
511 :message-type :error :visible t
512 :text "<b>Failed to load an image</b>"
513 :secondary-text (glib:gerror-message condition)
514 :signal (list :close #'widget-destroy :object t))
515 (return-from load-pixbufs nil))))
518 (defun fill-store (store directory)
519 (list-store-clear store)
520 (let ((dir #+cmu(unix:open-dir directory)
521 #+sbcl(sb-posix:opendir directory)))
524 as filename = #+cmu(unix:read-dir dir)
525 #+sbcl(let ((dirent (sb-posix:readdir dir)))
526 (unless (sb-grovel::foreign-nullp dirent)
527 (sb-posix:dirent-name dirent)))
529 unless (or (equal filename ".") (equal filename ".."))
530 do (let* ((pathname (format nil "~A~A" directory filename))
532 #+cmu(eq (unix:unix-file-kind pathname) :directory)
533 #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
534 (list-store-append store
537 (if directory-p folder-pixbuf file-pixbuf)
539 #+cmu(unix:close-dir dir)
540 #+sbcl(sb-posix:closedir dir))))
542 (defun sort-func (store a b)
543 (let ((a-dir-p (tree-model-value store a 'directory-p))
544 (b-dir-p (tree-model-value store b 'directory-p))
545 (a-name (tree-model-value store a 'filename))
546 (b-name (tree-model-value store b 'filename)))
548 ((and a-dir-p (not b-dir-p)) :before)
549 ((and (not a-dir-p) b-dir-p) :after)
550 ((string< a-name b-name) :before)
551 ((string> a-name b-name) :after)
554 (defun parent-dir (dir)
555 (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
558 (define-toplevel create-icon-view (window "Icon View demo"
561 (if (not (load-pixbufs))
562 (widget-destroy window)
563 (let* ((directory "/")
564 (store (make-instance 'list-store
565 :column-types '(string gdk:pixbuf boolean)
566 :column-names '(filename pixbuf directory-p)))
567 (icon-view (make-instance 'icon-view
568 :model store :selection-mode :multiple
569 :text-column 'filename :pixbuf-column 'pixbuf))
570 (up (make-instance 'tool-button
571 :stock "gtk-go-up" :is-important t :sensitive nil))
572 (home (make-instance 'tool-button
573 :stock "gtk-home" :is-important t)))
574 (tree-sortable-set-sort-func store :default #'sort-func)
575 (tree-sortable-set-sort-column store :default :ascending)
576 (fill-store store directory)
578 (signal-connect icon-view 'item-activated
580 (when (tree-model-value store path 'directory-p)
582 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
583 (fill-store store directory)
584 (setf (widget-sensitive-p up) t))))
586 (signal-connect up 'clicked
588 (unless (string= directory "/")
589 (setq directory (parent-dir directory))
590 (fill-store store directory)
592 (widget-sensitive-p home)
593 (not (string= directory (namestring (truename #p"clg:")))))
594 (setf (widget-sensitive-p up) (not (string= directory "/"))))))
596 (signal-connect home 'clicked
598 (setq directory (namestring (truename #p"clg:")))
599 (fill-store store directory)
600 (setf (widget-sensitive-p up) t)
601 (setf (widget-sensitive-p home) nil)))
603 (make-instance 'v-box
606 (make-instance 'toolbar :child up :child home)
607 :fill nil :expand nil)
608 :child (make-instance 'scrolled-window
609 :shadow-type :etched-in :policy :automatic
610 :child icon-view))))))
615 (define-toplevel create-image (window "Image" :resizable nil)
616 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
621 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
622 (flet ((create-label-in-frame (frame-label label-text &rest args)
624 (make-instance 'frame
626 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
627 :fill nil :expand nil)))
628 (make-instance 'h-box
629 :spacing 5 :parent window
630 :child-args '(:fill nil :expand nil)
631 :child (make-instance 'v-box
633 :child (create-label-in-frame "Normal Label" "This is a Normal label")
634 :child (create-label-in-frame "Multi-line Label"
635 "This is a Multi-line label.
638 :child (create-label-in-frame "Left Justified Label"
639 "This is a Left-Justified
643 :child (create-label-in-frame "Right Justified Label"
644 "This is a Right-Justified
648 :child (make-instance 'v-box
650 :child (create-label-in-frame "Line wrapped label"
651 "This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
652 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
655 :child (create-label-in-frame "Filled, wrapped label"
656 "This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do.
657 This is a new paragraph.
658 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
659 :justify :fill :wrap t)
661 :child (create-label-in-frame "Underlined label"
662 (#+cmu glib:latin1-to-unicode #+sbcl identity
663 "This label is underlined!
664 This one is underlined (æøåÆØÅ) in quite a funky fashion")
666 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
671 (defun layout-expose (layout event)
672 (when (eq (gdk:event-window event) (layout-bin-window layout))
673 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
674 (let ((imin (truncate gdk:x 10))
675 (imax (truncate (+ gdk:x gdk:width 9) 10))
676 (jmin (truncate gdk:y 10))
677 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
679 (let ((window (layout-bin-window layout))
680 (gc (style-black-gc (widget-style layout))))
682 for i from imin below imax
684 for j from jmin below jmax
685 unless (zerop (mod (+ i j) 2))
686 do (gdk:draw-rectangle
687 window gc t (* 10 i) (* 10 j)
688 (1+ (mod i 10)) (1+ (mod j 10)))))))))
691 (define-toplevel create-layout (window "Layout" :default-width 200
693 (let ((layout (make-instance 'layout
694 :parent (make-instance 'scrolled-window :parent window)
695 :width 1600 :height 128000 :events '(:exposure)
696 :signal (list 'expose-event #'layout-expose :object t))))
698 (with-slots (hadjustment vadjustment) layout
700 (adjustment-step-increment hadjustment) 10.0
701 (adjustment-step-increment vadjustment) 10.0))
705 (let ((text (format nil "Button ~D, ~D" i j)))
707 (make-instance (if (not (zerop (mod (+ i j) 2)))
710 :label text :visible t)
711 (* j 100) (* i 100)))))
714 for i from 16 below 1280
715 do (let ((text (format nil "Button ~D, ~D" i 0)))
717 (make-instance (if (not (zerop (mod i 2)))
720 :label text :visible t)
727 (define-simple-dialog create-list (dialog "List" :default-height 400)
728 (let* ((store (make-instance 'list-store
729 :column-types '(string integer boolean)
730 :column-names '(:foo :bar :baz)
731 :initial-content '(#("First" 12321 nil)
732 (:foo "Yeah" :baz t))))
733 (tree (make-instance 'tree-view :model store)))
736 with iter = (make-instance 'tree-iter)
738 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
740 (let ((column (make-instance 'tree-view-column :title "Column 1"))
741 (cell (make-instance 'cell-renderer-text)))
742 (cell-layout-pack column cell :expand t)
743 (cell-layout-add-attribute column cell 'text (column-index store :foo))
744 (tree-view-append-column tree column))
746 (let ((column (make-instance 'tree-view-column :title "Column 2"))
747 (cell (make-instance 'cell-renderer-text :background "orange")))
748 (cell-layout-pack column cell :expand t)
749 (cell-layout-add-attribute column cell 'text (column-index store :bar))
750 (tree-view-append-column tree column))
752 (let ((column (make-instance 'tree-view-column :title "Column 3"))
753 (cell (make-instance 'cell-renderer-text)))
754 (cell-layout-pack column cell :expand t)
755 (cell-layout-add-attribute column cell 'text (column-index store :baz))
756 (tree-view-append-column tree column))
758 (make-instance 'v-box
759 :parent dialog :border-width 10 :spacing 10
761 (make-instance 'h-box
763 :child (make-instance 'button
764 :label "Remove Selection"
765 :signal (list 'clicked
770 (make-instance 'tree-row-reference :model store :path path))
771 (tree-selection-get-selected-rows
772 (tree-view-selection tree)))))
774 #'(lambda (reference)
775 (list-store-remove store reference))
779 (make-instance 'h-box
781 :child (make-instance 'check-button
782 :label "Show Headers" :active t
783 :signal (list 'toggled
786 (tree-view-headers-visible-p tree)
787 (toggle-button-active-p button)))
789 :child (make-instance 'check-button
790 :label "Reorderable" :active nil
791 :signal (list 'toggled
794 (tree-view-reorderable-p tree)
795 (toggle-button-active-p button)))
798 (make-instance 'h-box
799 :child (make-instance 'label :label "Selection Mode: ")
800 :child (make-instance 'combo-box
801 :content '("Single" "Browse" "Multiple")
803 :signal (list 'changed
804 #'(lambda (combo-box)
807 (tree-view-selection tree))
809 #(:single :browse :multiple)
810 (combo-box-active combo-box))))
814 :child (make-instance 'scrolled-window
815 :child tree :hscrollbar-policy :automatic))))
820 (defun create-menu (depth tearoff)
821 (unless (zerop depth)
822 (let ((menu (make-instance 'menu)))
824 (let ((menu-item (make-instance 'tearoff-menu-item)))
825 (menu-shell-append menu menu-item)))
829 (make-instance 'radio-menu-item
830 :label (format nil "item ~2D - ~D" depth (1+ i)))))
832 (add-to-radio-group menu-item group)
833 (setq group menu-item))
834 (unless (zerop (mod depth 2))
835 (setf (check-menu-item-active-p menu-item) t))
836 (menu-shell-append menu menu-item)
838 (setf (widget-sensitive-p menu-item) nil))
839 (let ((submenu (create-menu (1- depth) t)))
841 (setf (menu-item-submenu menu-item) submenu))))))
845 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
846 (let* ((main (make-instance 'v-box :parent dialog))
847 ; (accel-group (make-instance 'accel-group))
848 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
849 ; (window-add-accel-group dialog accel-group)
851 (let ((menu-item (make-instance 'menu-item
852 :label (format nil "test~%line2"))))
853 (setf (menu-item-submenu menu-item) (create-menu 2 t))
854 (menu-shell-append menubar menu-item))
856 (let ((menu-item (make-instance 'menu-item :label "foo")))
857 (setf (menu-item-submenu menu-item) (create-menu 3 t))
858 (menu-shell-append menubar menu-item))
860 (let ((menu-item (make-instance 'menu-item :label "bar")))
861 (setf (menu-item-submenu menu-item) (create-menu 4 t))
862 (setf (menu-item-right-justified-p menu-item) t)
863 (menu-shell-append menubar menu-item))
865 (make-instance 'v-box
866 :spacing 10 :border-width 10 :parent main
867 :child (make-instance 'combo-box
871 collect (format nil "Item ~D" i))))
873 (widget-show-all main)))
878 (defun create-notebook-page (notebook page-num book-closed)
879 (let* ((title (format nil "Page ~D" page-num))
880 (page (make-instance 'frame :label title :border-width 10))
881 (v-box (make-instance 'v-box
882 :homogeneous t :border-width 10 :parent page)))
884 (make-instance 'h-box
885 :parent (list v-box :fill nil :padding 5) :homogeneous t
886 :child-args '(:padding 5)
887 :child (make-instance 'check-button
888 :label "Fill Tab" :active t
889 :signal (list 'toggled
892 (notebook-child-tab-fill-p page)
893 (toggle-button-active-p button)))
895 :child (make-instance 'check-button
897 :signal (list 'toggled
900 (notebook-child-tab-expand-p page)
901 (toggle-button-active-p button)))
903 :child (make-instance 'check-button
905 :signal (list 'toggled
908 (notebook-child-tab-pack page)
909 (if (toggle-button-active-p button)
913 :child (make-instance 'button
915 :signal (list 'clicked #'(lambda () (widget-hide page)))))
917 (let ((label-box (make-instance 'h-box
919 :child-args '(:expand nil)
920 :child (make-instance 'image :pixbuf book-closed)
921 :child (make-instance 'label :label title)))
922 (menu-box (make-instance 'h-box
924 :child-args '(:expand nil)
925 :child (make-instance 'image :pixbuf book-closed)
926 :child (make-instance 'label :label title))))
928 (widget-show-all page)
929 (notebook-append notebook page label-box menu-box))))
932 (define-simple-dialog create-notebook (dialog "Notebook")
933 (let ((main (make-instance 'v-box :parent dialog)))
934 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
935 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
936 (notebook (make-instance 'notebook
937 :border-width 10 :tab-pos :top :parent main)))
938 (flet ((set-image (page func pixbuf)
941 (first (container-children (funcall func notebook page))))
943 (signal-connect notebook 'switch-page
944 #'(lambda (pointer page)
945 (declare (ignore pointer))
946 (set-image page #'notebook-menu-label book-open)
947 (set-image page #'notebook-tab-label book-open)
948 (when (slot-boundp notebook 'current-page)
949 (let ((curpage (notebook-current-page notebook)))
950 (set-image curpage #'notebook-menu-label book-closed)
951 (set-image curpage #'notebook-tab-label book-closed))))))
952 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
954 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
956 (make-instance 'h-box
957 :spacing 5 :border-width 10
958 :parent (list main :expand nil)
959 :child-args '(:fill nil)
960 :child (make-instance 'check-button
962 :signal (list 'clicked
964 (if (toggle-button-active-p button)
965 (notebook-popup-enable notebook)
966 (notebook-popup-disable notebook)))
968 :child (make-instance 'check-button
969 :label "Homogeneous tabs"
970 :signal (list 'clicked
973 (notebook-homogeneous-p notebook)
974 (toggle-button-active-p button)))
977 (make-instance 'h-box
978 :spacing 5 :border-width 10
979 :parent (list main :expand nil)
980 :child-args '(:expand nil)
981 :child (make-instance 'label :label "Notebook Style: ")
982 :child (let ((scrollable-p nil))
983 (make-instance 'combo-box
984 :content '("Standard" "No tabs" "Scrollable") :active 0
985 :signal (list 'changed
986 #'(lambda (combo-box)
987 (case (combo-box-active combo-box)
989 (setf (notebook-show-tabs-p notebook) t)
991 (setq scrollable-p nil)
992 (setf (notebook-scrollable-p notebook) nil)
994 do (notebook-remove-page notebook 5))))
996 (setf (notebook-show-tabs-p notebook) nil)
998 (setq scrollable-p nil)
999 (setf (notebook-scrollable-p notebook) nil)
1001 do (notebook-remove-page notebook 5))))
1003 (unless scrollable-p
1004 (setq scrollable-p t)
1005 (setf (notebook-show-tabs-p notebook) t)
1006 (setf (notebook-scrollable-p notebook) t)
1007 (loop for i from 6 to 15
1008 do (create-notebook-page notebook i book-closed))))))
1010 :child (make-instance 'button
1011 :label "Show all Pages"
1012 :signal (list 'clicked
1014 (map-container nil #'widget-show notebook)))))
1016 (make-instance 'h-box
1017 :spacing 5 :border-width 10
1018 :parent (list main :expand nil)
1019 :child (make-instance 'button
1021 :signal (list 'clicked #'notebook-prev-page :object notebook))
1022 :child (make-instance 'button
1024 :signal (list 'clicked #'notebook-next-page :object notebook))
1025 :child (make-instance 'button
1027 :signal (let ((tab-pos 0))
1030 (setq tab-pos (mod (1+ tab-pos) 4))
1032 (notebook-tab-pos notebook)
1033 (svref #(:top :right :bottom :left) tab-pos))))))))
1034 (widget-show-all main)))
1039 (defun toggle-resize (child)
1040 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1042 (defun toggle-shrink (child)
1043 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1045 (defun create-pane-options (paned frame-label label1 label2)
1046 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1047 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1048 (let ((check-button (make-instance 'check-button :label "Resize")))
1049 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1050 (signal-connect check-button 'toggled
1051 #'toggle-resize :object (paned-child1 paned)))
1052 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1053 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1054 (signal-connect check-button 'toggled
1055 #'toggle-shrink :object (paned-child1 paned)))
1057 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1058 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1059 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1060 (signal-connect check-button 'toggled
1061 #'toggle-resize :object (paned-child2 paned)))
1062 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1063 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1064 (signal-connect check-button 'toggled
1065 #'toggle-shrink :object (paned-child2 paned)))
1066 (make-instance 'frame :label frame-label :border-width 4 :child table)))
1068 (define-toplevel create-panes (window "Panes")
1069 (let* ((hpaned (make-instance 'h-paned
1070 :child1 (make-instance 'frame
1071 :width-request 60 :height-request 60
1073 :child (make-instance 'button :label "Hi there"))
1074 :child2 (make-instance 'frame
1075 :width-request 80 :height-request 60
1077 (vpaned (make-instance 'v-paned
1080 :child2 (make-instance 'frame
1081 :width-request 80 :height-request 60
1082 :shadow-type :in))))
1084 (make-instance 'v-box
1086 :child-args '(:expand nil)
1087 :child (list vpaned :expand t)
1088 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1089 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1094 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1095 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1096 (activity-mode-button (make-instance 'check-button
1097 :label "Activity mode"))
1098 (timer (timeout-add 100
1100 (if (toggle-button-active-p activity-mode-button)
1101 (progress-bar-pulse progress)
1102 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1104 (progress-bar-fraction progress)
1110 (make-instance 'v-box
1111 :parent dialog :border-width 10 :spacing 10
1113 :child activity-mode-button)
1115 (signal-connect dialog 'destroy
1116 #'(lambda () (when timer (timeout-remove timer))))))
1121 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1122 (make-instance 'v-box
1123 :parent dialog :border-width 10 :spacing 10
1124 :children (make-radio-group 'radio-button
1125 '((:label "button1") (:label "button2") (:label "button3"))
1131 (define-simple-dialog create-range-controls (dialog "Range controls")
1132 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1133 (make-instance 'v-box
1134 :parent dialog :border-width 10 :spacing 10
1135 :child (make-instance 'h-scale
1136 :width-request 150 :adjustment adjustment :inverted t
1137 :update-policy :delayed :digits 1 :draw-value t)
1138 :child (make-instance 'h-scrollbar
1139 :adjustment adjustment :update-policy :continuous))))
1144 (define-simple-dialog create-reparent (dialog "Reparent")
1145 (let ((main (make-instance 'h-box
1146 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1147 (label (make-instance 'label :label "Hello World")))
1149 (flet ((create-frame (title)
1150 (let* ((frame (make-instance 'frame :label title :parent main))
1151 (box (make-instance 'v-box
1152 :spacing 5 :border-width 5 :parent frame))
1153 (button (make-instance 'button
1154 :label "switch" :parent (list box :expand nil))))
1155 (signal-connect button 'clicked
1157 (widget-reparent label box)))
1160 (box-pack-start (create-frame "Frame 1") label nil t 0)
1161 (create-frame "Frame 2"))
1162 (widget-show-all main)))
1167 (define-toplevel create-rulers (window "Rulers"
1168 :default-width 300 :default-height 300
1169 :events '(:pointer-motion :pointer-motion-hint))
1170 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1171 (h-ruler (make-instance 'h-ruler
1172 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1173 :position 0.0d0 :max-size 20.0d0))
1174 (v-ruler (make-instance 'v-ruler
1175 :lower 5.0d0 :upper 15.0d0
1176 :position 0.0d0 :max-size 20.0d0)))
1177 (signal-connect window 'motion-notify-event
1179 (widget-event h-ruler event)
1180 (widget-event v-ruler event)))
1181 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1182 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1187 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1189 :default-height 300)
1190 (let* ((scrolled-window
1191 (make-instance 'scrolled-window
1192 :parent dialog :border-width 10
1193 :vscrollbar-policy :automatic
1194 :hscrollbar-policy :automatic))
1196 (make-instance 'table
1197 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1198 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1199 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1201 (scrolled-window-add-with-viewport scrolled-window table)
1205 (make-instance 'toggle-button
1206 :label (format nil "button (~D,~D)~%" i j))))
1207 (table-attach table button i (1+ i) j (1+ j)))))
1208 (widget-show-all scrolled-window)))
1213 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1214 (let ((size-group (make-instance 'size-group)))
1215 (flet ((create-frame (label rows)
1216 (let ((table (make-instance 'table
1217 :n-rows (length rows) :n-columns 2 :homogeneous nil
1218 :row-spacing 5 :column-spacing 10 :border-width 5)))
1222 do (table-attach table
1223 (create-label (first row) :xalign 0 :yalign 1)
1224 0 1 i (1+ i) :x-options '(:expand :fill))
1225 (let ((combo (make-instance 'combo-box
1226 :content (rest row) :active 0)))
1227 (size-group-add-widget size-group combo)
1228 (table-attach table combo 1 2 i (1+ i))))
1229 (make-instance 'frame :label label :child table))))
1231 (make-instance 'v-box
1232 :parent dialog :border-width 5 :spacing 5
1233 :child (create-frame "Color Options"
1234 '(("Foreground" "Red" "Green" "Blue")
1235 ("Background" "Red" "Green" "Blue")))
1236 :child (create-frame "Line Options"
1237 '(("Dashing" "Solid" "Dashed" "Dotted")
1238 ("Line ends" "Square" "Round" "Arrow")))
1239 :child (create-check-button "Enable grouping"
1242 (size-group-mode size-group)
1243 (if active :horizontal :none)))
1249 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1251 (make-instance 'window
1252 :type type :default-width 100 :default-height 100
1253 :events '(:button-motion :pointer-motion-hint :button-press)
1254 :signal (list 'destroy destroy))))
1256 (widget-realize window)
1257 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1258 (let ((fixed (make-instance 'fixed :parent window)))
1259 (fixed-put fixed (create-image-widget source mask) px py))
1260 (widget-shape-combine-mask window mask px py))
1264 (declare (fixnum x-offset y-offset))
1265 (signal-connect window 'button-press-event
1267 (when (typep event 'gdk:button-press-event)
1268 (setq x-offset (truncate (gdk:event-x event)))
1269 (setq y-offset (truncate (gdk:event-y event)))
1271 (gdk:pointer-grab (widget-window window)
1272 :events '(:button-release :button-motion :pointer-motion-hint)
1275 (signal-connect window 'button-release-event
1277 (declare (ignore event))
1278 (grab-remove window)
1279 (gdk:pointer-ungrab)))
1281 (signal-connect window 'motion-notify-event
1283 (declare (ignore event))
1284 (multiple-value-bind (win xp yp mask)
1285 (gdk:window-get-pointer root-window)
1286 (declare (ignore mask win) (fixnum xp yp))
1287 (window-move window (- xp x-offset) (- yp y-offset))))))
1289 (window-move window x y)
1290 (widget-show-all window)
1294 (let ((modeller nil)
1297 (defun create-shapes ()
1298 (let ((root-window (gdk:get-root-window)))
1303 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1304 #'(lambda () (setq modeller nil))))
1305 (widget-destroy modeller))
1311 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1312 #'(lambda () (setq sheets nil))))
1313 (widget-destroy sheets))
1319 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1320 #'(lambda () (setq rings nil))))
1321 (widget-destroy rings)))))
1327 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1328 (let ((main (make-instance 'v-box
1329 :spacing 5 :border-width 10 :parent dialog)))
1331 (flet ((create-date-spinner (label adjustment shadow-type)
1332 (declare (ignore shadow-type))
1333 (make-instance 'v-box
1334 :child-args '(:expand nil)
1335 :child (make-instance 'label
1336 :label label :xalign 0.0 :yalign 0.5)
1337 :child (make-instance 'spin-button
1338 :adjustment adjustment :wrap t))))
1339 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1341 (declare (ignore sec min hour day daylight-p zone))
1342 (make-instance 'frame
1343 :label "Not accelerated" :parent main
1344 :child (make-instance 'h-box
1346 :child-args '(:padding 5)
1347 :child (create-date-spinner "Day : "
1348 (adjustment-new date 1 31 1 5 0) :out)
1349 :child (create-date-spinner "Month : "
1350 (adjustment-new month 1 12 1 5 0) :etched-in)
1351 :child (create-date-spinner "Year : "
1352 (adjustment-new year 0 2100 1 100 0) :in)))))
1354 (let ((spinner1 (make-instance 'spin-button
1355 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1356 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1357 (spinner2 (make-instance 'spin-button
1358 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1359 :climb-rate 1.0 :wrap t))
1360 (value-label (make-instance 'label :label "0")))
1361 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1364 (spin-button-digits spinner1)
1365 (floor (spin-button-value spinner2)))))
1367 (make-instance 'frame
1368 :label "Accelerated" :parent main
1369 :child (make-instance 'v-box
1372 (make-instance 'h-box
1373 :child-args '(:padding 5)
1374 :child (make-instance 'v-box
1375 :child (make-instance 'label
1377 :xalign 0.0 :yalign 0.5)
1379 :child (make-instance 'v-box
1380 :child (make-instance 'label
1382 :xalign 0.0 :yalign 0.5)
1384 :expand nil :padding 5)
1385 :child (make-instance 'check-button
1386 :label "Snap to 0.5-ticks" :active t
1387 :signal (list 'clicked
1390 (spin-button-snap-to-ticks-p spinner1)
1391 (toggle-button-active-p button)))
1393 :child (make-instance 'check-button
1394 :label "Numeric only input mode" :active t
1395 :signal (list 'clicked
1398 (spin-button-numeric-p spinner1)
1399 (toggle-button-active-p button)))
1403 (make-instance 'h-box
1404 :child-args '(:padding 5)
1405 :child (make-instance 'button
1406 :label "Value as Int"
1407 :signal (list 'clicked
1410 (label-label value-label)
1412 (spin-button-value-as-int
1414 :child (make-instance 'button
1415 :label "Value as Float"
1416 :signal (list 'clicked
1419 (label-label value-label)
1421 (format nil "~~,~DF"
1422 (spin-button-digits spinner1))
1423 (spin-button-value spinner1)))))))
1424 :padding 5 :expand nil))))
1425 (widget-show-all main)))
1430 (define-toplevel create-statusbar (window "Statusbar")
1431 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1432 (close-button (create-button '("close" :can-default t)
1433 #'widget-destroy :object window))
1436 (signal-connect statusbar 'text-popped
1437 #'(lambda (context-id text)
1438 (declare (ignore context-id))
1439 (format nil "Popped: ~A~%" text)))
1441 (make-instance 'v-box
1443 :child (make-instance 'v-box
1444 :border-width 10 :spacing 10
1445 :child (create-button "push something"
1447 (statusbar-push statusbar 1
1448 (format nil "something ~D" (incf counter)))))
1449 :child (create-button "pop"
1451 (statusbar-pop statusbar 1)))
1452 :child (create-button "steal #4"
1454 (statusbar-remove statusbar 1 4)))
1455 :child (create-button "dump stack")
1456 :child (create-button "test contexts"))
1457 :child (list (make-instance 'h-separator) :expand nil)
1459 (make-instance 'v-box :border-width 10 :child close-button)
1461 :child (list statusbar :expand nil))
1463 (widget-grab-focus close-button)))
1468 (define-simple-dialog create-idle-test (dialog "Idle Test")
1469 (let ((label (make-instance 'label
1470 :label "count: 0" :xpad 10 :ypad 10))
1473 (signal-connect dialog 'destroy
1474 #'(lambda () (when idle (idle-remove idle))))
1476 (make-instance 'v-box
1477 :parent dialog :border-width 10 :spacing 10
1479 :child (make-instance 'frame
1480 :label "Label Container" :border-width 5
1481 :child(make-instance 'v-box
1482 :children (make-radio-group 'radio-button
1483 '((:label "Resize-Parent" :value :parent :active t)
1484 (:label "Resize-Queue" :value :queue)
1485 (:label "Resize-Immediate" :value :immediate))
1488 (container-resize-mode (dialog-action-area dialog)) mode))))))
1490 (dialog-add-button dialog "Start"
1497 (setf (label-label label) (format nil "count: ~D" count))
1500 (dialog-add-button dialog "Stop"
1504 (setq idle nil))))))
1510 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1511 (let ((label (make-instance 'label
1512 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1515 (signal-connect dialog 'destroy
1516 #'(lambda () (when timer (timeout-remove timer))))
1518 (dialog-add-button dialog "Start"
1525 (setf (label-label label) (format nil "count: ~D" count))
1528 (dialog-add-button dialog "Stop"
1531 (timeout-remove timer)
1532 (setq timer nil))))))
1537 (define-simple-dialog create-text (dialog "Text" :default-width 400
1538 :default-height 400)
1539 (let* ((text-view (make-instance 'text-view
1540 :border-width 10 :visible t :wrap-mode :word))
1541 (buffer (text-view-buffer text-view))
1544 (text-buffer-create-tag buffer "Bold" :weight :bold)
1545 (text-buffer-create-tag buffer "Italic" :style :italic)
1546 (text-buffer-create-tag buffer "Underline" :underline :single)
1548 (flet ((create-toggle-callback (tag-name)
1549 (let ((tag (text-tag-table-lookup
1550 (text-buffer-tag-table buffer) tag-name)))
1552 (unless (eq (and (find tag active-tags) t) active)
1555 (push tag active-tags)
1556 (setq active-tags (delete tag active-tags)))
1557 (multiple-value-bind (non-zero-p start end)
1558 (text-buffer-get-selection-bounds buffer)
1559 (declare (ignore non-zero-p))
1561 (text-buffer-apply-tag buffer tag start end)
1562 (text-buffer-remove-tag buffer tag start end))))))))
1565 (make-instance 'action-group
1566 :action (make-instance 'toggle-action
1567 :name "Bold" :stock-id "gtk-bold" :label "Bold"
1568 :accelerator "<control>B" :tooltip "Bold"
1569 :callback (create-toggle-callback "Bold"))
1570 :action (make-instance 'toggle-action
1571 :name "Italic" :stock-id "gtk-italic" :label "Italic"
1572 :accelerator "<control>I" :tooltip "Italic"
1573 :callback (create-toggle-callback "Italic"))
1574 :action (make-instance 'toggle-action
1575 :name "Underline" :stock-id "gtk-underline"
1576 :label "Underline" :accelerator "<control>U"
1577 :tooltip "Underline"
1578 :callback (create-toggle-callback "Underline"))))
1579 (ui (make-instance 'ui-manager
1580 :action-group actions
1581 :ui '((:toolbar "ToolBar"
1583 (:toolitem "Italic")
1584 (:toolitem "Underline"))))))
1586 ;; Callback to activate/deactivate toolbar buttons when cursor
1588 (signal-connect buffer 'mark-set
1589 #'(lambda (location mark)
1590 (declare (ignore mark))
1591 (text-tag-table-foreach (text-buffer-tag-table buffer)
1596 (text-iter-has-tag-p location tag)
1597 (not (text-iter-begins-tag-p location tag)))
1598 (text-iter-ends-tag-p location tag))))
1599 (unless (eq active (and (find tag active-tags) t))
1601 (push tag active-tags)
1602 (setq active-tags (delete tag active-tags)))
1604 (toggle-action-active-p
1605 (action-group-get-action actions (text-tag-name tag)))
1608 ;; Callback to apply active tags when a character is inserted
1609 (signal-connect buffer 'insert-text
1610 #'(lambda (iter &rest args)
1611 (declare (ignore args))
1612 (let ((before (text-buffer-get-iter-at-offset buffer
1613 (1- (text-iter-offset iter)))))
1615 for tag in active-tags
1616 do (text-buffer-apply-tag buffer tag before iter))))
1619 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1620 (container-add dialog text-view)))))
1625 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1626 (make-instance 'v-box
1627 :border-width 10 :spacing 10 :parent dialog
1630 collect (make-instance 'toggle-button
1631 :label (format nil "Button~D" (1+ n))))))
1637 (defun create-toolbar (window)
1638 (make-instance 'toolbar
1639 :show-tooltips t :show-arrow nil
1641 ;; Insert a stock item
1642 :child (make-instance 'tool-button
1644 :tip-text "Destroy toolbar"
1645 :tip-private "Toolbar/Quit"
1646 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1648 :child (make-instance 'separator-tool-item)
1650 :child (make-instance 'tool-button
1651 :label "Horizontal" :stock "gtk-go-forward"
1652 :tip-text "Horizontal toolbar layout"
1653 :tip-private "Toolbar/Horizontal"
1654 :signal (list 'clicked
1656 (setf (toolbar-orientation toolbar) :horizontal))
1659 :child (make-instance 'tool-button
1660 :label "Vertical" :stock "gtk-go-down"
1661 :tip-text "Vertical toolbar layout"
1662 :tip-private "Toolbar/Vertical"
1663 :signal (list 'clicked
1665 (setf (toolbar-orientation toolbar) :vertical))
1668 :child (make-instance 'separator-tool-item)
1670 :children (make-radio-group 'radio-tool-button
1671 '((:label "Icons" :stock "gtk-justify-left"
1672 :tip-text "Only show toolbar icons"
1673 :tip-private "Toolbar/IconsOnly"
1675 (:label "Both" :stock "gtk-justify-center"
1676 :tip-text "Show toolbar icons and text"
1677 :tip-private "Toolbar/Both"
1678 :value :both :active t)
1679 (:label "Text" :stock "gtk-justify-right"
1680 :tip-text "Show toolbar text"
1681 :tip-private "Toolbar/TextOnly"
1684 #'(lambda (toolbar style)
1685 (setf (toolbar-style toolbar) style))
1688 :child (make-instance 'separator-tool-item)
1690 :child (make-instance 'tool-item
1691 :child (make-instance 'entry)
1692 :tip-text "This is an unusable GtkEntry"
1693 :tip-private "Hey don't click me!")
1695 :child (make-instance 'separator-tool-item)
1697 :child (make-instance 'tool-button
1698 :label "Enable" :stock "gtk-add"
1699 :tip-text "Enable tooltips"
1700 :tip-private "Toolbar/EnableTooltips"
1701 :signal (list 'clicked
1703 (setf (toolbar-show-tooltips-p toolbar) t))
1706 :child (make-instance 'tool-button
1707 :label "Disable" :stock "gtk-remove"
1708 :tip-text "Disable tooltips"
1709 :tip-private "Toolbar/DisableTooltips"
1710 :signal (list 'clicked
1712 (setf (toolbar-show-tooltips-p toolbar) nil))
1715 ;; :child (make-instance 'separator-tool-item)
1717 ;; :child (make-instance 'tool-button
1718 ;; :label "GTK" :icon #p"clg:examples;gtk.png"
1719 ;; :tip-text "GTK+ Logo"
1720 ;; :tip-private "Toolbar/GTK+")
1723 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1724 (container-add window (create-toolbar window)))
1729 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1730 (make-instance 'v-box
1732 :child (create-label "Above")
1733 :child (make-instance 'h-separator)
1734 :child (make-instance 'h-box
1737 (make-instance 'handle-box
1738 :child (create-toolbar window)
1739 :signal (list 'child-attached
1741 (format t "~A attached~%" child)))
1742 :signal (list 'child-detached
1744 (format t "~A detached~%" child))))
1745 :expand nil :fill :nil))
1746 :child (make-instance 'h-separator)
1747 :child (create-label "Below")))
1752 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1753 (let ((tooltips (make-instance 'tooltips)))
1754 (flet ((create-button (label tip-text tip-private)
1755 (let ((button (make-instance 'toggle-button :label label)))
1756 (tooltips-set-tip tooltips button tip-text tip-private)
1758 (make-instance 'v-box
1759 :parent dialog :border-width 10 :spacing 10
1760 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1761 :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")))))
1766 (defvar *ui-description*
1767 '((:menubar "MenuBar"
1772 (:menuitem "SaveAs")
1775 (:menu "PreferencesMenu"
1781 (:menuitem "Square")
1782 (:menuitem "Rectangle")
1786 (:menuitem "About")))
1791 (:toolitem "Logo"))))
1793 (define-toplevel create-ui-manager (window "UI Manager")
1794 (let ((ui (make-instance 'ui-manager)))
1795 (window-add-accel-group window (ui-manager-accel-group ui))
1796 (ui-manager-insert-action-group ui
1797 (make-instance 'action-group :name "Actions"
1798 :action (make-instance 'action :name "FileMenu" :label "_File")
1799 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1800 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1801 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1802 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1803 :action (make-instance 'action
1804 :name "New" :stock-id "gtk-new" :label "_New"
1805 :accelerator "<control>N" :tooltip "Create a new file")
1806 :action (make-instance 'action
1807 :name "Open" :stock-id "gtk-open" :label "_Open"
1808 :accelerator "<control>O" :tooltip "Open a file"
1809 :callback #'create-file-chooser)
1810 :action (make-instance 'action
1811 :name "Save" :stock-id "gtk-save" :label "_Save"
1812 :accelerator "<control>S" :tooltip "Save current file")
1813 :action (make-instance 'action
1814 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1815 :tooltip "Save to a file")
1816 :action (make-instance 'action
1817 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1818 :accelerator "<control>Q" :tooltip "Quit"
1819 :callback (list #'widget-destroy :object window))
1820 :action (make-instance 'action
1821 :name "About" :label "_About"
1822 :accelerator "<control>A" :tooltip "About")
1823 :action (make-instance 'action
1824 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1825 :action (make-instance 'toggle-action
1826 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1827 :accelerator "<control>B" :tooltip "Bold" :active t)
1828 :actions (make-radio-group 'radio-action
1829 '((:name "Red" :value :red :label "_Red"
1830 :accelerator "<control>R" :tooltip "Blood")
1831 (:name "Green" :value :green :label "_Green"
1832 :accelerator "<control>G" :tooltip "Grass" :active t)
1833 (:name "Blue" :value :blue :label "_Blue"
1834 :accelerator "<control>B" :tooltip "Sky"))
1835 #'(lambda (active) (print active)))
1836 :actions (make-radio-group 'radio-action
1837 '((:name "Square" :value :square :label "_Square"
1838 :accelerator "<control>S" :tooltip "Square")
1839 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1840 :accelerator "<control>R" :tooltip "Rectangle")
1841 (:name "Oval" :value :oval :label "_Oval"
1842 :accelerator "<control>O" :tooltip "Egg"))
1843 #'(lambda (active) (print active)))))
1845 (ui-manager-add-ui ui *ui-description*)
1847 (make-instance 'v-box
1850 (ui-manager-get-widget ui "/MenuBar")
1851 :expand nil :fill nil)
1853 (ui-manager-get-widget ui "/ToolBar")
1854 :expand nil :fill nil)
1855 :child (make-instance 'label
1856 :label "Type Ctrl+Q to quit"
1857 :xalign 0.5 :yalign 0.5
1858 :width-request 200 :height-request 200))))
1864 (defun create-main-window ()
1865 ;; (rc-parse "clg:examples;testgtkrc2")
1866 ;; (rc-parse "clg:examples;testgtkrc")
1868 (let* ((button-specs
1869 '(("button box" create-button-box)
1870 ("buttons" create-buttons)
1871 ("calendar" create-calendar)
1872 ("check buttons" create-check-buttons)
1873 ("color selection" create-color-selection)
1874 ("cursors" create-cursors)
1875 ("dialog" create-dialog)
1877 ("entry" create-entry)
1878 ;; ("event watcher")
1879 ("enxpander" create-expander)
1880 ("file chooser" create-file-chooser)
1881 ("font selection" create-font-selection)
1882 ("handle box" create-handle-box)
1883 #+gtk2.6 ("icon view" create-icon-view)
1884 ("image" create-image)
1885 ("labels" create-labels)
1886 ("layout" create-layout)
1887 ("list" create-list)
1888 ("menus" create-menus)
1890 ("notebook" create-notebook)
1891 ("panes" create-panes)
1892 ("progress bar" create-progress-bar)
1893 ("radio buttons" create-radio-buttons)
1894 ("range controls" create-range-controls)
1896 ("reparent" create-reparent)
1897 ("rulers" create-rulers)
1898 ;; ("saved position")
1899 ("scrolled windows" create-scrolled-windows)
1900 ("size group" create-size-group)
1901 ("shapes" create-shapes)
1902 ("spinbutton" create-spins)
1903 ("statusbar" create-statusbar)
1904 ("test idle" create-idle-test)
1905 ;; ("test mainloop")
1906 ;; ("test scrolling")
1907 ;; ("test selection")
1908 ("test timeout" create-timeout-test)
1909 ("text" create-text)
1910 ("toggle buttons" create-toggle-buttons)
1911 ("toolbar" create-toolbar-window)
1912 ("tooltips" create-tooltips)
1913 ;; ("tree" #|create-tree|#)
1914 ("UI manager" create-ui-manager)
1916 (main-window (make-instance 'window
1917 :title "testgtk.lisp" :name "main_window"
1918 :default-width 200 :default-height 400
1919 :allow-grow t :allow-shrink nil))
1920 (scrolled-window (make-instance 'scrolled-window
1921 :hscrollbar-policy :automatic
1922 :vscrollbar-policy :automatic
1924 (close-button (make-instance 'button
1925 :label "close" :can-default t
1926 :signal (list 'clicked #'widget-destroy
1927 :object main-window))))
1929 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1931 (window-icon main-window)
1932 (gdk:pixbuf-add-alpha icon t 254 254 252)))
1935 (make-instance 'v-box
1937 :child-args '(:expand nil)
1938 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1939 :child (list (make-instance 'label :label (clg-version)) :fill nil)
1940 :child (list (make-instance 'label
1941 :label #-cmu(format nil "~A (~A)"
1942 (lisp-implementation-type)
1943 (lisp-implementation-version))
1944 ;; The version string in CMUCL is far too long
1945 #+cmu(lisp-implementation-type))
1947 :child (list scrolled-window :expand t)
1948 :child (make-instance 'h-separator)
1949 :child (make-instance 'v-box
1950 :homogeneous nil :spacing 10 :border-width 10
1951 :child close-button))
1954 (make-instance 'v-box
1955 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1956 :children (mapcar #'(lambda (spec)
1957 (apply #'create-button spec))
1959 (scrolled-window-add-with-viewport scrolled-window content-box))
1961 (widget-grab-focus close-button)
1962 (widget-show-all main-window)
1966 (create-main-window)