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.30 2005/04/23 16:48:49 espen Exp $
32 #+cmucl(asdf:oos 'asdf:load-op :gtk)
35 (:use "COMMON-LISP" "GTK"))
37 (in-package "TESTGTK")
39 (defmacro define-toplevel (name (window title &rest initargs) &body body)
43 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
44 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
48 (if (not (widget-visible-p ,window))
50 (widget-hide ,window))))))
53 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
59 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
60 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
64 (if (not (widget-visible-p ,dialog))
66 (widget-hide ,dialog))))))
69 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
70 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
72 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
76 ;;; Pixmaps used in some of the tests
118 (defvar book-closed-xpm
143 (defvar mini-page-xpm
166 (defvar book-open-xpm
193 (defun create-bbox-in-frame (class frame-label spacing width height layout)
194 (declare (ignore width height))
195 (make-instance 'frame
197 :child (make-instance class
198 :border-width 5 :layout-style layout :spacing spacing
199 :child (make-instance 'button :stock "gtk-ok")
200 :child (make-instance 'button :stock "gtk-cancel")
201 :child (make-instance 'button :stock "gtk-help"))))
203 (define-toplevel create-button-box (window "Button Boxes")
204 (make-instance 'v-box
205 :parent window :border-width 10 :spacing 10
206 :child (make-instance 'frame
207 :label "Horizontal Button Boxes"
208 :child (make-instance 'v-box
209 :border-width 10 :spacing 10
212 (apply #'create-bbox-in-frame
214 '(("Spread" 40 85 20 :spread)
215 ("Edge" 40 85 20 :edge)
216 ("Start" 40 85 20 :start)
217 ("End" 40 85 20 :end)))))
218 :child (make-instance 'frame
219 :label "Vertical Button Boxes"
220 :child (make-instance 'h-box
221 :border-width 10 :spacing 10
224 (apply #'create-bbox-in-frame
226 '(("Spread" 30 85 20 :spread)
227 ("Edge" 30 85 20 :edge)
228 ("Start" 30 85 20 :start)
229 ("End" 30 85 20 :end)))))))
234 (define-simple-dialog create-buttons (dialog "Buttons")
235 (let ((table (make-instance 'table
236 :n-rows 3 :n-columns 3 :homogeneous nil
237 :row-spacing 5 :column-spacing 5 :border-width 10
241 collect (make-instance 'button
242 :label (format nil "button~D" (1+ n))))))
246 (let ((button (nth (+ (* 3 row) column) buttons))
247 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
248 (signal-connect button 'clicked
250 (if (widget-visible-p button+1)
251 (widget-hide button+1)
252 (widget-show button+1))))
253 (table-attach table button column (1+ column) row (1+ row)
254 :options '(:expand :fill)))))))
259 (define-simple-dialog create-calendar (dialog "Calendar")
260 (make-instance 'v-box
261 :parent dialog :border-width 10
262 :child (make-instance 'calendar)))
267 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
268 (make-instance 'v-box
269 :border-width 10 :spacing 10 :parent dialog
272 collect (make-instance 'check-button
273 :label (format nil "Button~D" n)))))
279 (define-dialog create-color-selection (dialog "Color selection dialog"
280 'color-selection-dialog
281 :allow-grow nil :allow-shrink nil
283 (with-slots (colorsel) dialog
284 (let ((button (make-instance 'check-button :label "Show Opacity")))
285 (dialog-add-action-widget dialog button
288 (color-selection-has-opacity-control-p colorsel)
289 (toggle-button-active-p button)))))
291 (let ((button (make-instance 'check-button :label "Show Palette")))
292 (dialog-add-action-widget dialog button
295 (color-selection-has-palette-p colorsel)
296 (toggle-button-active-p button)))))
298 (signal-connect dialog :ok
300 (let ((color (color-selection-current-color colorsel)))
301 (format t "Selected color: ~A~%" color)
302 (setf (color-selection-current-color colorsel) color)
303 (widget-hide dialog))))
305 (signal-connect dialog :cancel #'widget-destroy :object t)))
310 (defun clamp (n min-val max-val)
311 (declare (number n min-val max-val))
312 (max (min n max-val) min-val))
314 (defun set-cursor (spinner drawing-area label)
317 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
319 (setf (label-label label) (string-downcase cursor))
320 (setf (widget-cursor drawing-area) cursor)))
322 (defun cursor-expose (drawing-area event)
323 (declare (ignore event))
324 (multiple-value-bind (width height)
325 (widget-get-size-allocation drawing-area)
326 (let* ((window (widget-window drawing-area))
327 (style (widget-style drawing-area))
328 (white-gc (style-white-gc style))
329 (gray-gc (style-bg-gc style :normal))
330 (black-gc (style-black-gc style)))
331 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
332 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
334 (gdk:draw-rectangle window gray-gc t (floor width 3)
335 (floor height 3) (floor width 3)
339 (define-simple-dialog create-cursors (dialog "Cursors")
340 (let ((spinner (make-instance 'spin-button
341 :adjustment (adjustment-new
343 (1- (glib:enum-int :last-cursor 'gdk:cursor-type))
345 (drawing-area (make-instance 'drawing-area
346 :width-request 80 :height-request 80
347 :events '(:exposure :button-press)))
348 (label (make-instance 'label :label "XXX")))
350 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
352 (signal-connect drawing-area 'button-press-event
354 (case (gdk:event-button event)
355 (1 (spin-button-spin spinner :step-forward))
356 (3 (spin-button-spin spinner :step-backward)))
359 (signal-connect drawing-area 'scroll-event
361 (case (gdk:event-direction event)
362 (:up (spin-button-spin spinner :step-forward))
363 (:down (spin-button-spin spinner :step-backward)))
366 (signal-connect spinner 'changed
368 (set-cursor spinner drawing-area label)))
370 (make-instance 'v-box
371 :parent dialog :border-width 10 :spacing 5
373 (make-instance 'h-box
376 (make-instance 'label :label "Cursor Value : ")
380 :child (make-instance 'frame
381 :label "Cursor Area" :label-xalign 0.5 :border-width 10
383 :child (list label :expand nil))
385 (widget-realize drawing-area)
386 (set-cursor spinner drawing-area label)))
392 (defun create-dialog ()
394 (setq dialog (make-instance 'dialog
395 :title "Dialog" :default-width 200
397 :button (list "gtk-ok" #'widget-destroy :object t)
398 :signal (list 'destroy
400 (setq dialog nil)))))
402 (let ((label (make-instance 'label
403 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
405 (signal-connect dialog "Toggle"
407 (if (widget-visible-p label)
409 (widget-show label))))))
411 (if (widget-visible-p dialog)
413 (widget-show dialog))))
418 (define-simple-dialog create-entry (dialog "Entry")
419 (let ((main (make-instance 'v-box
420 :border-width 10 :spacing 10 :parent dialog)))
422 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
423 (editable-select-region entry 0 5) ; this has no effect when
425 ;; (editable-insert-text entry "great " 6)
426 ;; (editable-delete-text entry 6 12)
428 (let ((combo (make-instance 'combo-box-entry
433 "item3 item3 item3 item3"
434 "item4 item4 item4 item4 item4"
435 "item5 item5 item5 item5 item5 item5"
436 "item6 item6 item6 item6 item6"
437 "item7 item7 item7 item7"
440 (with-slots (child) combo
441 (setf (editable-text child) "hello world")
442 (editable-select-region child 0)))
444 (flet ((create-check-button (label slot)
445 (make-instance 'check-button
446 :label label :active t :parent main
447 :signal (list 'toggled
449 (setf (slot-value entry slot)
450 (toggle-button-active-p button)))
453 (create-check-button "Editable" 'editable)
454 (create-check-button "Visible" 'visibility)
455 (create-check-button "Sensitive" 'sensitive)))))
460 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
461 (make-instance 'v-box
462 :parent dialog :spacing 5 :border-width 5
463 :child (create-label "Expander demo. Click on the triangle for details.")
464 :child (make-instance 'expander
466 :child (create-label "Details can be shown or hidden."))))
469 ;; File chooser dialog
471 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
472 (file-chooser-add-filter dialog
473 (make-instance 'file-filter :name "All files" :pattern "*"))
474 (file-chooser-add-filter dialog
475 (make-instance 'file-filter :name "Common Lisp source code"
476 :patterns '("*.lisp" "*.lsp")))
478 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
479 (dialog-add-button dialog "gtk-ok"
481 (if (slot-boundp dialog 'filename)
482 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
483 (write-line "No files selected"))
484 (widget-destroy dialog))))
487 ;; Font selection dialog
489 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
490 (make-instance 'h-box
491 :parent window :spacing 8 :border-width 8
492 :child (make-instance 'label :label "Pick a font")
493 :child (make-instance 'font-button
494 :use-font t :title "Font Selection Dialog")))
500 (let ((file-pixbuf nil)
502 (defun load-pixbufs ()
506 file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
507 folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
508 (glib:glib-error (condition)
509 (make-instance 'message-dialog
510 :message-type :error :visible t
511 :text "<b>Failed to load an image</b>"
512 :secondary-text (glib:gerror-message condition)
513 :signal (list :close #'widget-destroy :object t))
514 (return-from load-pixbufs nil))))
517 (defun fill-store (store directory)
518 (list-store-clear store)
519 (let ((dir #+cmu(unix:open-dir directory)
520 #+sbcl(sb-posix:opendir directory)))
523 as filename = #+cmu(unix:read-dir dir)
524 #+sbcl(let ((dirent (sb-posix:readdir dir)))
525 (unless (sb-grovel::foreign-nullp dirent)
526 (sb-posix:dirent-name dirent)))
528 unless (or (equal filename ".") (equal filename ".."))
529 do (let* ((pathname (format nil "~A~A" directory filename))
531 #+cmu(eq (unix:unix-file-kind pathname) :directory)
532 #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
533 (list-store-append store
536 (if directory-p folder-pixbuf file-pixbuf)
538 #+cmu(unix:close-dir dir)
539 #+sbcl(sb-posix:closedir dir))))
541 (defun sort-func (store a b)
542 (let ((a-dir-p (tree-model-value store a 'directory-p))
543 (b-dir-p (tree-model-value store b 'directory-p))
544 (a-name (tree-model-value store a 'filename))
545 (b-name (tree-model-value store b 'filename)))
547 ((and a-dir-p (not b-dir-p)) :before)
548 ((and (not a-dir-p) b-dir-p) :after)
549 ((string< a-name b-name) :before)
550 ((string> a-name b-name) :after)
553 (defun parent-dir (dir)
554 (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
557 (define-toplevel create-icon-view (window "Icon View demo"
560 (if (not (load-pixbufs))
561 (widget-destroy window)
562 (let* ((directory "/")
563 (store (make-instance 'list-store
564 :column-types '(string gdk:pixbuf boolean)
565 :column-names '(filename pixbuf directory-p)))
566 (icon-view (make-instance 'icon-view
567 :model store :selection-mode :multiple
568 :text-column 'filename :pixbuf-column 'pixbuf))
569 (up (make-instance 'tool-button
570 :stock "gtk-go-up" :is-important t :sensitive nil))
571 (home (make-instance 'tool-button
572 :stock "gtk-home" :is-important t)))
573 (tree-sortable-set-sort-func store :default #'sort-func)
574 (tree-sortable-set-sort-column store :default :ascending)
575 (fill-store store directory)
577 (signal-connect icon-view 'item-activated
579 (when (tree-model-value store path 'directory-p)
581 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
582 (fill-store store directory)
583 (setf (widget-sensitive-p up) t))))
585 (signal-connect up 'clicked
587 (unless (string= directory "/")
588 (setq directory (parent-dir directory))
589 (fill-store store directory)
591 (widget-sensitive-p home)
592 (not (string= directory (namestring (truename #p"clg:")))))
593 (setf (widget-sensitive-p up) (not (string= directory "/"))))))
595 (signal-connect home 'clicked
597 (setq directory (namestring (truename #p"clg:")))
598 (fill-store store directory)
599 (setf (widget-sensitive-p up) t)
600 (setf (widget-sensitive-p home) nil)))
602 (make-instance 'v-box
605 (make-instance 'toolbar :child up :child home)
606 :fill nil :expand nil)
607 :child (make-instance 'scrolled-window
608 :shadow-type :etched-in :policy :automatic
609 :child icon-view))))))
614 (define-toplevel create-image (window "Image" :resizable nil)
615 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
620 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
621 (flet ((create-label-in-frame (frame-label label-text &rest args)
623 (make-instance 'frame
625 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
626 :fill nil :expand nil)))
627 (make-instance 'h-box
628 :spacing 5 :parent window
629 :child-args '(:fill nil :expand nil)
630 :child (make-instance 'v-box
632 :child (create-label-in-frame "Normal Label" "This is a Normal label")
633 :child (create-label-in-frame "Multi-line Label"
634 "This is a Multi-line label.
637 :child (create-label-in-frame "Left Justified Label"
638 "This is a Left-Justified
642 :child (create-label-in-frame "Right Justified Label"
643 "This is a Right-Justified
647 :child (make-instance 'v-box
649 :child (create-label-in-frame "Line wrapped label"
650 "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.
651 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
654 :child (create-label-in-frame "Filled, wrapped label"
655 "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.
656 This is a new paragraph.
657 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
658 :justify :fill :wrap t)
660 :child (create-label-in-frame "Underlined label"
661 (#+cmu glib:latin1-to-unicode #+sbcl identity
662 "This label is underlined!
663 This one is underlined (æøåÆØÅ) in quite a funky fashion")
665 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
670 (defun layout-expose (layout event)
671 (when (eq (gdk:event-window event) (layout-bin-window layout))
672 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
673 (let ((imin (truncate gdk:x 10))
674 (imax (truncate (+ gdk:x gdk:width 9) 10))
675 (jmin (truncate gdk:y 10))
676 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
678 (let ((window (layout-bin-window layout))
679 (gc (style-black-gc (widget-style layout))))
681 for i from imin below imax
683 for j from jmin below jmax
684 unless (zerop (mod (+ i j) 2))
685 do (gdk:draw-rectangle
686 window gc t (* 10 i) (* 10 j)
687 (1+ (mod i 10)) (1+ (mod j 10)))))))))
690 (define-toplevel create-layout (window "Layout" :default-width 200
692 (let ((layout (make-instance 'layout
693 :parent (make-instance 'scrolled-window :parent window)
694 :width 1600 :height 128000 :events '(:exposure)
695 :signal (list 'expose-event #'layout-expose :object t))))
697 (with-slots (hadjustment vadjustment) layout
699 (adjustment-step-increment hadjustment) 10.0
700 (adjustment-step-increment vadjustment) 10.0))
704 (let ((text (format nil "Button ~D, ~D" i j)))
706 (make-instance (if (not (zerop (mod (+ i j) 2)))
709 :label text :visible t)
710 (* j 100) (* i 100)))))
713 for i from 16 below 1280
714 do (let ((text (format nil "Button ~D, ~D" i 0)))
716 (make-instance (if (not (zerop (mod i 2)))
719 :label text :visible t)
726 (define-simple-dialog create-list (dialog "List" :default-height 400)
727 (let* ((store (make-instance 'list-store
728 :column-types '(string integer boolean)
729 :column-names '(:foo :bar :baz)
730 :initial-content '(#("First" 12321 nil)
731 (:foo "Yeah" :baz t))))
732 (tree (make-instance 'tree-view :model store)))
735 with iter = (make-instance 'tree-iter)
737 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
739 (let ((column (make-instance 'tree-view-column :title "Column 1"))
740 (cell (make-instance 'cell-renderer-text)))
741 (cell-layout-pack column cell :expand t)
742 (cell-layout-add-attribute column cell 'text (column-index store :foo))
743 (tree-view-append-column tree column))
745 (let ((column (make-instance 'tree-view-column :title "Column 2"))
746 (cell (make-instance 'cell-renderer-text :background "orange")))
747 (cell-layout-pack column cell :expand t)
748 (cell-layout-add-attribute column cell 'text (column-index store :bar))
749 (tree-view-append-column tree column))
751 (let ((column (make-instance 'tree-view-column :title "Column 3"))
752 (cell (make-instance 'cell-renderer-text)))
753 (cell-layout-pack column cell :expand t)
754 (cell-layout-add-attribute column cell 'text (column-index store :baz))
755 (tree-view-append-column tree column))
757 (make-instance 'v-box
758 :parent dialog :border-width 10 :spacing 10
760 (make-instance 'h-box
762 :child (make-instance 'button
763 :label "Remove Selection"
764 :signal (list 'clicked
769 (make-instance 'tree-row-reference :model store :path path))
770 (tree-selection-get-selected-rows
771 (tree-view-selection tree)))))
773 #'(lambda (reference)
774 (list-store-remove store reference))
778 (make-instance 'h-box
780 :child (make-instance 'check-button
781 :label "Show Headers" :active t
782 :signal (list 'toggled
785 (tree-view-headers-visible-p tree)
786 (toggle-button-active-p button)))
788 :child (make-instance 'check-button
789 :label "Reorderable" :active nil
790 :signal (list 'toggled
793 (tree-view-reorderable-p tree)
794 (toggle-button-active-p button)))
797 (make-instance 'h-box
798 :child (make-instance 'label :label "Selection Mode: ")
799 :child (make-instance 'combo-box
800 :content '("Single" "Browse" "Multiple")
802 :signal (list 'changed
803 #'(lambda (combo-box)
806 (tree-view-selection tree))
808 #(:single :browse :multiple)
809 (combo-box-active combo-box))))
813 :child (make-instance 'scrolled-window
814 :child tree :hscrollbar-policy :automatic))))
819 (defun create-menu (depth tearoff)
820 (unless (zerop depth)
821 (let ((menu (make-instance 'menu)))
823 (let ((menu-item (make-instance 'tearoff-menu-item)))
824 (menu-shell-append menu menu-item)))
828 (make-instance 'radio-menu-item
829 :label (format nil "item ~2D - ~D" depth (1+ i)))))
831 (add-to-radio-group menu-item group)
832 (setq group menu-item))
833 (unless (zerop (mod depth 2))
834 (setf (check-menu-item-active-p menu-item) t))
835 (menu-shell-append menu menu-item)
837 (setf (widget-sensitive-p menu-item) nil))
838 (let ((submenu (create-menu (1- depth) t)))
840 (setf (menu-item-submenu menu-item) submenu))))))
844 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
845 (let* ((main (make-instance 'v-box :parent dialog))
846 ; (accel-group (make-instance 'accel-group))
847 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
848 ; (window-add-accel-group dialog accel-group)
850 (let ((menu-item (make-instance 'menu-item
851 :label (format nil "test~%line2"))))
852 (setf (menu-item-submenu menu-item) (create-menu 2 t))
853 (menu-shell-append menubar menu-item))
855 (let ((menu-item (make-instance 'menu-item :label "foo")))
856 (setf (menu-item-submenu menu-item) (create-menu 3 t))
857 (menu-shell-append menubar menu-item))
859 (let ((menu-item (make-instance 'menu-item :label "bar")))
860 (setf (menu-item-submenu menu-item) (create-menu 4 t))
861 (setf (menu-item-right-justified-p menu-item) t)
862 (menu-shell-append menubar menu-item))
864 (make-instance 'v-box
865 :spacing 10 :border-width 10 :parent main
866 :child (make-instance 'combo-box
870 collect (format nil "Item ~D" i))))
872 (widget-show-all main)))
877 (defun create-notebook-page (notebook page-num book-closed)
878 (let* ((title (format nil "Page ~D" page-num))
879 (page (make-instance 'frame :label title :border-width 10))
880 (v-box (make-instance 'v-box
881 :homogeneous t :border-width 10 :parent page)))
883 (make-instance 'h-box
884 :parent (list v-box :fill nil :padding 5) :homogeneous t
885 :child-args '(:padding 5)
886 :child (make-instance 'check-button
887 :label "Fill Tab" :active t
888 :signal (list 'toggled
891 (notebook-child-tab-fill-p page)
892 (toggle-button-active-p button)))
894 :child (make-instance 'check-button
896 :signal (list 'toggled
899 (notebook-child-tab-expand-p page)
900 (toggle-button-active-p button)))
902 :child (make-instance 'check-button
904 :signal (list 'toggled
907 (notebook-child-tab-pack page)
908 (if (toggle-button-active-p button)
912 :child (make-instance 'button
914 :signal (list 'clicked #'(lambda () (widget-hide page)))))
916 (let ((label-box (make-instance 'h-box
918 :child-args '(:expand nil)
919 :child (make-instance 'image :pixbuf book-closed)
920 :child (make-instance 'label :label title)))
921 (menu-box (make-instance 'h-box
923 :child-args '(:expand nil)
924 :child (make-instance 'image :pixbuf book-closed)
925 :child (make-instance 'label :label title))))
927 (widget-show-all page)
928 (notebook-append notebook page label-box menu-box))))
931 (define-simple-dialog create-notebook (dialog "Notebook")
932 (let ((main (make-instance 'v-box :parent dialog)))
933 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
934 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
935 (notebook (make-instance 'notebook
936 :border-width 10 :tab-pos :top :parent main)))
937 (flet ((set-image (page func pixbuf)
940 (first (container-children (funcall func notebook page))))
942 (signal-connect notebook 'switch-page
943 #'(lambda (pointer page)
944 (declare (ignore pointer))
945 (set-image page #'notebook-menu-label book-open)
946 (set-image page #'notebook-tab-label book-open)
947 (when (slot-boundp notebook 'current-page)
948 (let ((curpage (notebook-current-page notebook)))
949 (set-image curpage #'notebook-menu-label book-closed)
950 (set-image curpage #'notebook-tab-label book-closed))))))
951 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
953 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
955 (make-instance 'h-box
956 :spacing 5 :border-width 10
957 :parent (list main :expand nil)
958 :child-args '(:fill nil)
959 :child (make-instance 'check-button
961 :signal (list 'clicked
963 (if (toggle-button-active-p button)
964 (notebook-popup-enable notebook)
965 (notebook-popup-disable notebook)))
967 :child (make-instance 'check-button
968 :label "Homogeneous tabs"
969 :signal (list 'clicked
972 (notebook-homogeneous-p notebook)
973 (toggle-button-active-p button)))
976 (make-instance 'h-box
977 :spacing 5 :border-width 10
978 :parent (list main :expand nil)
979 :child-args '(:expand nil)
980 :child (make-instance 'label :label "Notebook Style: ")
981 :child (let ((scrollable-p nil))
982 (make-instance 'combo-box
983 :content '("Standard" "No tabs" "Scrollable") :active 0
984 :signal (list 'changed
985 #'(lambda (combo-box)
986 (case (combo-box-active combo-box)
988 (setf (notebook-show-tabs-p notebook) t)
990 (setq scrollable-p nil)
991 (setf (notebook-scrollable-p notebook) nil)
993 do (notebook-remove-page notebook 5))))
995 (setf (notebook-show-tabs-p notebook) nil)
997 (setq scrollable-p nil)
998 (setf (notebook-scrollable-p notebook) nil)
1000 do (notebook-remove-page notebook 5))))
1002 (unless scrollable-p
1003 (setq scrollable-p t)
1004 (setf (notebook-show-tabs-p notebook) t)
1005 (setf (notebook-scrollable-p notebook) t)
1006 (loop for i from 6 to 15
1007 do (create-notebook-page notebook i book-closed))))))
1009 :child (make-instance 'button
1010 :label "Show all Pages"
1011 :signal (list 'clicked
1013 (map-container nil #'widget-show notebook)))))
1015 (make-instance 'h-box
1016 :spacing 5 :border-width 10
1017 :parent (list main :expand nil)
1018 :child (make-instance 'button
1020 :signal (list 'clicked #'notebook-prev-page :object notebook))
1021 :child (make-instance 'button
1023 :signal (list 'clicked #'notebook-next-page :object notebook))
1024 :child (make-instance 'button
1026 :signal (let ((tab-pos 0))
1029 (setq tab-pos (mod (1+ tab-pos) 4))
1031 (notebook-tab-pos notebook)
1032 (svref #(:top :right :bottom :left) tab-pos))))))))
1033 (widget-show-all main)))
1038 (defun toggle-resize (child)
1039 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1041 (defun toggle-shrink (child)
1042 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1044 (defun create-pane-options (paned frame-label label1 label2)
1045 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1046 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1047 (let ((check-button (make-instance 'check-button :label "Resize")))
1048 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1049 (signal-connect check-button 'toggled
1050 #'toggle-resize :object (paned-child1 paned)))
1051 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1052 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1053 (signal-connect check-button 'toggled
1054 #'toggle-shrink :object (paned-child1 paned)))
1056 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1057 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1058 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1059 (signal-connect check-button 'toggled
1060 #'toggle-resize :object (paned-child2 paned)))
1061 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1062 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1063 (signal-connect check-button 'toggled
1064 #'toggle-shrink :object (paned-child2 paned)))
1065 (make-instance 'frame :label frame-label :border-width 4 :child table)))
1067 (define-toplevel create-panes (window "Panes")
1068 (let* ((hpaned (make-instance 'h-paned
1069 :child1 (make-instance 'frame
1070 :width-request 60 :height-request 60
1072 :child (make-instance 'button :label "Hi there"))
1073 :child2 (make-instance 'frame
1074 :width-request 80 :height-request 60
1076 (vpaned (make-instance 'v-paned
1079 :child2 (make-instance 'frame
1080 :width-request 80 :height-request 60
1081 :shadow-type :in))))
1083 (make-instance 'v-box
1085 :child-args '(:expand nil)
1086 :child (list vpaned :expand t)
1087 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1088 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1093 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1094 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1095 (activity-mode-button (make-instance 'check-button
1096 :label "Activity mode"))
1097 (timer (timeout-add 100
1099 (if (toggle-button-active-p activity-mode-button)
1100 (progress-bar-pulse progress)
1101 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1103 (progress-bar-fraction progress)
1109 (make-instance 'v-box
1110 :parent dialog :border-width 10 :spacing 10
1112 :child activity-mode-button)
1114 (signal-connect dialog 'destroy
1115 #'(lambda () (when timer (timeout-remove timer))))))
1120 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1121 (make-instance 'v-box
1122 :parent dialog :border-width 10 :spacing 10
1123 :children (make-radio-group 'radio-button
1124 '((:label "button1") (:label "button2") (:label "button3"))
1130 (define-simple-dialog create-range-controls (dialog "Range controls")
1131 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1132 (make-instance 'v-box
1133 :parent dialog :border-width 10 :spacing 10
1134 :child (make-instance 'h-scale
1135 :width-request 150 :adjustment adjustment :inverted t
1136 :update-policy :delayed :digits 1 :draw-value t)
1137 :child (make-instance 'h-scrollbar
1138 :adjustment adjustment :update-policy :continuous))))
1143 (define-simple-dialog create-reparent (dialog "Reparent")
1144 (let ((main (make-instance 'h-box
1145 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1146 (label (make-instance 'label :label "Hello World")))
1148 (flet ((create-frame (title)
1149 (let* ((frame (make-instance 'frame :label title :parent main))
1150 (box (make-instance 'v-box
1151 :spacing 5 :border-width 5 :parent frame))
1152 (button (make-instance 'button
1153 :label "switch" :parent (list box :expand nil))))
1154 (signal-connect button 'clicked
1156 (widget-reparent label box)))
1159 (box-pack-start (create-frame "Frame 1") label nil t 0)
1160 (create-frame "Frame 2"))
1161 (widget-show-all main)))
1166 (define-toplevel create-rulers (window "Rulers"
1167 :default-width 300 :default-height 300
1168 :events '(:pointer-motion :pointer-motion-hint))
1169 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1170 (h-ruler (make-instance 'h-ruler
1171 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1172 :position 0.0d0 :max-size 20.0d0))
1173 (v-ruler (make-instance 'v-ruler
1174 :lower 5.0d0 :upper 15.0d0
1175 :position 0.0d0 :max-size 20.0d0)))
1176 (signal-connect window 'motion-notify-event
1178 (widget-event h-ruler event)
1179 (widget-event v-ruler event)))
1180 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1181 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1186 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1188 :default-height 300)
1189 (let* ((scrolled-window
1190 (make-instance 'scrolled-window
1191 :parent dialog :border-width 10
1192 :vscrollbar-policy :automatic
1193 :hscrollbar-policy :automatic))
1195 (make-instance 'table
1196 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1197 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1198 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1200 (scrolled-window-add-with-viewport scrolled-window table)
1204 (make-instance 'toggle-button
1205 :label (format nil "button (~D,~D)~%" i j))))
1206 (table-attach table button i (1+ i) j (1+ j)))))
1207 (widget-show-all scrolled-window)))
1212 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1213 (let ((size-group (make-instance 'size-group)))
1214 (flet ((create-frame (label rows)
1215 (let ((table (make-instance 'table
1216 :n-rows (length rows) :n-columns 2 :homogeneous nil
1217 :row-spacing 5 :column-spacing 10 :border-width 5)))
1221 do (table-attach table
1222 (create-label (first row) :xalign 0 :yalign 1)
1223 0 1 i (1+ i) :x-options '(:expand :fill))
1224 (let ((combo (make-instance 'combo-box
1225 :content (rest row) :active 0)))
1226 (size-group-add-widget size-group combo)
1227 (table-attach table combo 1 2 i (1+ i))))
1228 (make-instance 'frame :label label :child table))))
1230 (make-instance 'v-box
1231 :parent dialog :border-width 5 :spacing 5
1232 :child (create-frame "Color Options"
1233 '(("Foreground" "Red" "Green" "Blue")
1234 ("Background" "Red" "Green" "Blue")))
1235 :child (create-frame "Line Options"
1236 '(("Dashing" "Solid" "Dashed" "Dotted")
1237 ("Line ends" "Square" "Round" "Arrow")))
1238 :child (create-check-button "Enable grouping"
1241 (size-group-mode size-group)
1242 (if active :horizontal :none)))
1248 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1250 (make-instance 'window
1251 :type type :default-width 100 :default-height 100
1252 :events '(:button-motion :pointer-motion-hint :button-press)
1253 :signal (list 'destroy destroy))))
1255 (widget-realize window)
1256 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1257 (let ((fixed (make-instance 'fixed :parent window)))
1258 (fixed-put fixed (create-image-widget source mask) px py))
1259 (widget-shape-combine-mask window mask px py))
1263 (declare (fixnum x-offset y-offset))
1264 (signal-connect window 'button-press-event
1266 (when (typep event 'gdk:button-press-event)
1267 (setq x-offset (truncate (gdk:event-x event)))
1268 (setq y-offset (truncate (gdk:event-y event)))
1270 (gdk:pointer-grab (widget-window window)
1271 :events '(:button-release :button-motion :pointer-motion-hint)
1274 (signal-connect window 'button-release-event
1276 (declare (ignore event))
1277 (grab-remove window)
1278 (gdk:pointer-ungrab)))
1280 (signal-connect window 'motion-notify-event
1282 (declare (ignore event))
1283 (multiple-value-bind (win xp yp mask)
1284 (gdk:window-get-pointer root-window)
1285 (declare (ignore mask win) (fixnum xp yp))
1286 (window-move window (- xp x-offset) (- yp y-offset))))))
1288 (window-move window x y)
1289 (widget-show-all window)
1293 (let ((modeller nil)
1296 (defun create-shapes ()
1297 (let ((root-window (gdk:get-root-window)))
1302 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1303 #'(lambda () (setq modeller nil))))
1304 (widget-destroy modeller))
1310 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1311 #'(lambda () (setq sheets nil))))
1312 (widget-destroy sheets))
1318 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1319 #'(lambda () (setq rings nil))))
1320 (widget-destroy rings)))))
1326 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1327 (let ((main (make-instance 'v-box
1328 :spacing 5 :border-width 10 :parent dialog)))
1330 (flet ((create-date-spinner (label adjustment shadow-type)
1331 (declare (ignore shadow-type))
1332 (make-instance 'v-box
1333 :child-args '(:expand nil)
1334 :child (make-instance 'label
1335 :label label :xalign 0.0 :yalign 0.5)
1336 :child (make-instance 'spin-button
1337 :adjustment adjustment :wrap t))))
1338 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1340 (declare (ignore sec min hour day daylight-p zone))
1341 (make-instance 'frame
1342 :label "Not accelerated" :parent main
1343 :child (make-instance 'h-box
1345 :child-args '(:padding 5)
1346 :child (create-date-spinner "Day : "
1347 (adjustment-new date 1 31 1 5 0) :out)
1348 :child (create-date-spinner "Month : "
1349 (adjustment-new month 1 12 1 5 0) :etched-in)
1350 :child (create-date-spinner "Year : "
1351 (adjustment-new year 0 2100 1 100 0) :in)))))
1353 (let ((spinner1 (make-instance 'spin-button
1354 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1355 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1356 (spinner2 (make-instance 'spin-button
1357 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1358 :climb-rate 1.0 :wrap t))
1359 (value-label (make-instance 'label :label "0")))
1360 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1363 (spin-button-digits spinner1)
1364 (floor (spin-button-value spinner2)))))
1366 (make-instance 'frame
1367 :label "Accelerated" :parent main
1368 :child (make-instance 'v-box
1371 (make-instance 'h-box
1372 :child-args '(:padding 5)
1373 :child (make-instance 'v-box
1374 :child (make-instance 'label
1376 :xalign 0.0 :yalign 0.5)
1378 :child (make-instance 'v-box
1379 :child (make-instance 'label
1381 :xalign 0.0 :yalign 0.5)
1383 :expand nil :padding 5)
1384 :child (make-instance 'check-button
1385 :label "Snap to 0.5-ticks" :active t
1386 :signal (list 'clicked
1389 (spin-button-snap-to-ticks-p spinner1)
1390 (toggle-button-active-p button)))
1392 :child (make-instance 'check-button
1393 :label "Numeric only input mode" :active t
1394 :signal (list 'clicked
1397 (spin-button-numeric-p spinner1)
1398 (toggle-button-active-p button)))
1402 (make-instance 'h-box
1403 :child-args '(:padding 5)
1404 :child (make-instance 'button
1405 :label "Value as Int"
1406 :signal (list 'clicked
1409 (label-label value-label)
1411 (spin-button-value-as-int
1413 :child (make-instance 'button
1414 :label "Value as Float"
1415 :signal (list 'clicked
1418 (label-label value-label)
1420 (format nil "~~,~DF"
1421 (spin-button-digits spinner1))
1422 (spin-button-value spinner1)))))))
1423 :padding 5 :expand nil))))
1424 (widget-show-all main)))
1429 (define-toplevel create-statusbar (window "Statusbar")
1430 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1431 (close-button (create-button '("close" :can-default t)
1432 #'widget-destroy :object window))
1435 (signal-connect statusbar 'text-popped
1436 #'(lambda (context-id text)
1437 (declare (ignore context-id))
1438 (format nil "Popped: ~A~%" text)))
1440 (make-instance 'v-box
1442 :child (make-instance 'v-box
1443 :border-width 10 :spacing 10
1444 :child (create-button "push something"
1446 (statusbar-push statusbar 1
1447 (format nil "something ~D" (incf counter)))))
1448 :child (create-button "pop"
1450 (statusbar-pop statusbar 1)))
1451 :child (create-button "steal #4"
1453 (statusbar-remove statusbar 1 4)))
1454 :child (create-button "dump stack")
1455 :child (create-button "test contexts"))
1456 :child (list (make-instance 'h-separator) :expand nil)
1458 (make-instance 'v-box :border-width 10 :child close-button)
1460 :child (list statusbar :expand nil))
1462 (widget-grab-focus close-button)))
1467 (define-simple-dialog create-idle-test (dialog "Idle Test")
1468 (let ((label (make-instance 'label
1469 :label "count: 0" :xpad 10 :ypad 10))
1472 (signal-connect dialog 'destroy
1473 #'(lambda () (when idle (idle-remove idle))))
1475 (make-instance 'v-box
1476 :parent dialog :border-width 10 :spacing 10
1478 :child (make-instance 'frame
1479 :label "Label Container" :border-width 5
1480 :child(make-instance 'v-box
1481 :children (make-radio-group 'radio-button
1482 '((:label "Resize-Parent" :value :parent :active t)
1483 (:label "Resize-Queue" :value :queue)
1484 (:label "Resize-Immediate" :value :immediate))
1487 (container-resize-mode (dialog-action-area dialog)) mode))))))
1489 (dialog-add-button dialog "Start"
1496 (setf (label-label label) (format nil "count: ~D" count))
1499 (dialog-add-button dialog "Stop"
1503 (setq idle nil))))))
1509 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1510 (let ((label (make-instance 'label
1511 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1514 (signal-connect dialog 'destroy
1515 #'(lambda () (when timer (timeout-remove timer))))
1517 (dialog-add-button dialog "Start"
1524 (setf (label-label label) (format nil "count: ~D" count))
1527 (dialog-add-button dialog "Stop"
1530 (timeout-remove timer)
1531 (setq timer nil))))))
1536 (define-simple-dialog create-text (dialog "Text" :default-width 400
1537 :default-height 400)
1538 (let* ((text-view (make-instance 'text-view
1539 :border-width 10 :visible t :wrap-mode :word))
1540 (buffer (text-view-buffer text-view))
1543 (text-buffer-create-tag buffer "Bold" :weight :bold)
1544 (text-buffer-create-tag buffer "Italic" :style :italic)
1545 (text-buffer-create-tag buffer "Underline" :underline :single)
1547 (flet ((create-toggle-callback (tag-name)
1548 (let ((tag (text-tag-table-lookup
1549 (text-buffer-tag-table buffer) tag-name)))
1551 (unless (eq (and (find tag active-tags) t) active)
1554 (push tag active-tags)
1555 (setq active-tags (delete tag active-tags)))
1556 (multiple-value-bind (non-zero-p start end)
1557 (text-buffer-get-selection-bounds buffer)
1558 (declare (ignore non-zero-p))
1560 (text-buffer-apply-tag buffer tag start end)
1561 (text-buffer-remove-tag buffer tag start end))))))))
1564 (make-instance 'action-group
1565 :action (make-instance 'toggle-action
1566 :name "Bold" :stock-id "gtk-bold" :label "Bold"
1567 :accelerator "<control>B" :tooltip "Bold"
1568 :callback (create-toggle-callback "Bold"))
1569 :action (make-instance 'toggle-action
1570 :name "Italic" :stock-id "gtk-italic" :label "Italic"
1571 :accelerator "<control>I" :tooltip "Italic"
1572 :callback (create-toggle-callback "Italic"))
1573 :action (make-instance 'toggle-action
1574 :name "Underline" :stock-id "gtk-underline"
1575 :label "Underline" :accelerator "<control>U"
1576 :tooltip "Underline"
1577 :callback (create-toggle-callback "Underline"))))
1578 (ui (make-instance 'ui-manager
1579 :action-group actions
1580 :ui '((:toolbar "ToolBar"
1582 (:toolitem "Italic")
1583 (:toolitem "Underline"))))))
1585 ;; Callback to activate/deactivate toolbar buttons when cursor
1587 (signal-connect buffer 'mark-set
1588 #'(lambda (location mark)
1589 (declare (ignore mark))
1590 (text-tag-table-foreach (text-buffer-tag-table buffer)
1595 (text-iter-has-tag-p location tag)
1596 (not (text-iter-begins-tag-p location tag)))
1597 (text-iter-ends-tag-p location tag))))
1598 (unless (eq active (and (find tag active-tags) t))
1600 (push tag active-tags)
1601 (setq active-tags (delete tag active-tags)))
1603 (toggle-action-active-p
1604 (action-group-get-action actions (text-tag-name tag)))
1607 ;; Callback to apply active tags when a character is inserted
1608 (signal-connect buffer 'insert-text
1609 #'(lambda (iter &rest args)
1610 (declare (ignore args))
1611 (let ((before (text-buffer-get-iter-at-offset buffer
1612 (1- (text-iter-offset iter)))))
1614 for tag in active-tags
1615 do (text-buffer-apply-tag buffer tag before iter))))
1618 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1619 (container-add dialog text-view)))))
1624 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1625 (make-instance 'v-box
1626 :border-width 10 :spacing 10 :parent dialog
1629 collect (make-instance 'toggle-button
1630 :label (format nil "Button~D" (1+ n))))))
1636 (defun create-toolbar (window)
1637 (make-instance 'toolbar
1638 :show-tooltips t :show-arrow nil
1640 ;; Insert a stock item
1641 :child (make-instance 'tool-button
1643 :tip-text "Destroy toolbar"
1644 :tip-private "Toolbar/Quit"
1645 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1647 :child (make-instance 'separator-tool-item)
1649 :child (make-instance 'tool-button
1650 :label "Horizontal" :stock "gtk-go-forward"
1651 :tip-text "Horizontal toolbar layout"
1652 :tip-private "Toolbar/Horizontal"
1653 :signal (list 'clicked
1655 (setf (toolbar-orientation toolbar) :horizontal))
1658 :child (make-instance 'tool-button
1659 :label "Vertical" :stock "gtk-go-down"
1660 :tip-text "Vertical toolbar layout"
1661 :tip-private "Toolbar/Vertical"
1662 :signal (list 'clicked
1664 (setf (toolbar-orientation toolbar) :vertical))
1667 :child (make-instance 'separator-tool-item)
1669 :children (make-radio-group 'radio-tool-button
1670 '((:label "Icons" :stock "gtk-justify-left"
1671 :tip-text "Only show toolbar icons"
1672 :tip-private "Toolbar/IconsOnly"
1674 (:label "Both" :stock "gtk-justify-center"
1675 :tip-text "Show toolbar icons and text"
1676 :tip-private "Toolbar/Both"
1677 :value :both :active t)
1678 (:label "Text" :stock "gtk-justify-right"
1679 :tip-text "Show toolbar text"
1680 :tip-private "Toolbar/TextOnly"
1683 #'(lambda (toolbar style)
1684 (setf (toolbar-style toolbar) style))
1687 :child (make-instance 'separator-tool-item)
1689 :child (make-instance 'tool-item
1690 :child (make-instance 'entry)
1691 :tip-text "This is an unusable GtkEntry"
1692 :tip-private "Hey don't click me!")
1694 :child (make-instance 'separator-tool-item)
1696 :child (make-instance 'tool-button
1697 :label "Enable" :stock "gtk-add"
1698 :tip-text "Enable tooltips"
1699 :tip-private "Toolbar/EnableTooltips"
1700 :signal (list 'clicked
1702 (setf (toolbar-show-tooltips-p toolbar) t))
1705 :child (make-instance 'tool-button
1706 :label "Disable" :stock "gtk-remove"
1707 :tip-text "Disable tooltips"
1708 :tip-private "Toolbar/DisableTooltips"
1709 :signal (list 'clicked
1711 (setf (toolbar-show-tooltips-p toolbar) nil))
1714 ;; :child (make-instance 'separator-tool-item)
1716 ;; :child (make-instance 'tool-button
1717 ;; :label "GTK" :icon #p"clg:examples;gtk.png"
1718 ;; :tip-text "GTK+ Logo"
1719 ;; :tip-private "Toolbar/GTK+")
1722 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1723 (container-add window (create-toolbar window)))
1728 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1729 (make-instance 'v-box
1731 :child (create-label "Above")
1732 :child (make-instance 'h-separator)
1733 :child (make-instance 'h-box
1736 (make-instance 'handle-box
1737 :child (create-toolbar window)
1738 :signal (list 'child-attached
1740 (format t "~A attached~%" child)))
1741 :signal (list 'child-detached
1743 (format t "~A detached~%" child))))
1744 :expand nil :fill :nil))
1745 :child (make-instance 'h-separator)
1746 :child (create-label "Below")))
1751 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1752 (let ((tooltips (make-instance 'tooltips)))
1753 (flet ((create-button (label tip-text tip-private)
1754 (let ((button (make-instance 'toggle-button :label label)))
1755 (tooltips-set-tip tooltips button tip-text tip-private)
1757 (make-instance 'v-box
1758 :parent dialog :border-width 10 :spacing 10
1759 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1760 :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")))))
1765 (defvar *ui-description*
1766 '((:menubar "MenuBar"
1771 (:menuitem "SaveAs")
1774 (:menu "PreferencesMenu"
1780 (:menuitem "Square")
1781 (:menuitem "Rectangle")
1785 (:menuitem "About")))
1790 (:toolitem "Logo"))))
1792 (define-toplevel create-ui-manager (window "UI Manager")
1793 (let ((ui (make-instance 'ui-manager)))
1794 (window-add-accel-group window (ui-manager-accel-group ui))
1795 (ui-manager-insert-action-group ui
1796 (make-instance 'action-group :name "Actions"
1797 :action (make-instance 'action :name "FileMenu" :label "_File")
1798 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1799 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1800 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1801 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1802 :action (make-instance 'action
1803 :name "New" :stock-id "gtk-new" :label "_New"
1804 :accelerator "<control>N" :tooltip "Create a new file")
1805 :action (make-instance 'action
1806 :name "Open" :stock-id "gtk-open" :label "_Open"
1807 :accelerator "<control>O" :tooltip "Open a file"
1808 :callback #'create-file-chooser)
1809 :action (make-instance 'action
1810 :name "Save" :stock-id "gtk-save" :label "_Save"
1811 :accelerator "<control>S" :tooltip "Save current file")
1812 :action (make-instance 'action
1813 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1814 :tooltip "Save to a file")
1815 :action (make-instance 'action
1816 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1817 :accelerator "<control>Q" :tooltip "Quit"
1818 :callback (list #'widget-destroy :object window))
1819 :action (make-instance 'action
1820 :name "About" :label "_About"
1821 :accelerator "<control>A" :tooltip "About")
1822 :action (make-instance 'action
1823 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1824 :action (make-instance 'toggle-action
1825 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1826 :accelerator "<control>B" :tooltip "Bold" :active t)
1827 :actions (make-radio-group 'radio-action
1828 '((:name "Red" :value :red :label "_Red"
1829 :accelerator "<control>R" :tooltip "Blood")
1830 (:name "Green" :value :green :label "_Green"
1831 :accelerator "<control>G" :tooltip "Grass" :active t)
1832 (:name "Blue" :value :blue :label "_Blue"
1833 :accelerator "<control>B" :tooltip "Sky"))
1834 #'(lambda (active) (print active)))
1835 :actions (make-radio-group 'radio-action
1836 '((:name "Square" :value :square :label "_Square"
1837 :accelerator "<control>S" :tooltip "Square")
1838 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1839 :accelerator "<control>R" :tooltip "Rectangle")
1840 (:name "Oval" :value :oval :label "_Oval"
1841 :accelerator "<control>O" :tooltip "Egg"))
1842 #'(lambda (active) (print active)))))
1844 (ui-manager-add-ui ui *ui-description*)
1846 (make-instance 'v-box
1849 (ui-manager-get-widget ui "/MenuBar")
1850 :expand nil :fill nil)
1852 (ui-manager-get-widget ui "/ToolBar")
1853 :expand nil :fill nil)
1854 :child (make-instance 'label
1855 :label "Type <alt> to start"
1856 :xalign 0.5 :yalign 0.5
1857 :width-request 200 :height-request 200))))
1863 (defun create-main-window ()
1864 ;; (rc-parse "clg:examples;testgtkrc2")
1865 ;; (rc-parse "clg:examples;testgtkrc")
1867 (let* ((button-specs
1868 '(("button box" create-button-box)
1869 ("buttons" create-buttons)
1870 ("calendar" create-calendar)
1871 ("check buttons" create-check-buttons)
1872 ("color selection" create-color-selection)
1873 ("cursors" create-cursors)
1874 ("dialog" create-dialog)
1876 ("entry" create-entry)
1877 ;; ("event watcher")
1878 ("enxpander" create-expander)
1879 ("file chooser" create-file-chooser)
1880 ("font selection" create-font-selection)
1881 ("handle box" create-handle-box)
1882 #+gtk2.6 ("icon view" create-icon-view)
1883 ("image" create-image)
1884 ("labels" create-labels)
1885 ("layout" create-layout)
1886 ("list" create-list)
1887 ("menus" create-menus)
1889 ("notebook" create-notebook)
1890 ("panes" create-panes)
1891 ("progress bar" create-progress-bar)
1892 ("radio buttons" create-radio-buttons)
1893 ("range controls" create-range-controls)
1895 ("reparent" create-reparent)
1896 ("rulers" create-rulers)
1897 ;; ("saved position")
1898 ("scrolled windows" create-scrolled-windows)
1899 ("size group" create-size-group)
1900 ("shapes" create-shapes)
1901 ("spinbutton" create-spins)
1902 ("statusbar" create-statusbar)
1903 ("test idle" create-idle-test)
1904 ;; ("test mainloop")
1905 ;; ("test scrolling")
1906 ;; ("test selection")
1907 ("test timeout" create-timeout-test)
1908 ("text" create-text)
1909 ("toggle buttons" create-toggle-buttons)
1910 ("toolbar" create-toolbar-window)
1911 ("tooltips" create-tooltips)
1912 ;; ("tree" #|create-tree|#)
1913 ("UI manager" create-ui-manager)
1915 (main-window (make-instance 'window
1916 :title "testgtk.lisp" :name "main_window"
1917 :default-width 200 :default-height 400
1918 :allow-grow t :allow-shrink nil))
1919 (scrolled-window (make-instance 'scrolled-window
1920 :hscrollbar-policy :automatic
1921 :vscrollbar-policy :automatic
1923 (close-button (make-instance 'button
1924 :label "close" :can-default t
1925 :signal (list 'clicked #'widget-destroy
1926 :object main-window))))
1928 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1930 (window-icon main-window)
1931 (gdk:pixbuf-add-alpha icon t 254 254 252)))
1934 (make-instance 'v-box
1936 :child-args '(:expand nil)
1937 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1938 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1939 :child (list (make-instance 'label
1940 :label #-cmu(format nil "~A (~A)"
1941 (lisp-implementation-type)
1942 (lisp-implementation-version))
1943 ;; The version string in CMUCL is far too long
1944 #+cmu(lisp-implementation-type))
1946 :child (list scrolled-window :expand t)
1947 :child (make-instance 'h-separator)
1948 :child (make-instance 'v-box
1949 :homogeneous nil :spacing 10 :border-width 10
1950 :child close-button))
1953 (make-instance 'v-box
1954 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1955 :children (mapcar #'(lambda (spec)
1956 (apply #'create-button spec))
1958 (scrolled-window-add-with-viewport scrolled-window content-box))
1960 (widget-grab-focus close-button)
1961 (widget-show-all main-window)
1965 (create-main-window)