1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 ;; $Id: testgtk.lisp,v 1.16 2005-01-12 14:03:04 espen Exp $
24 (defmacro define-toplevel (name (window title &rest initargs) &body body)
28 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
29 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
32 (if (not (widget-visible-p ,window))
33 (widget-show-all ,window)
34 (widget-hide ,window)))))
37 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
43 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
44 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
47 (if (not (widget-visible-p ,dialog))
49 (widget-hide ,dialog)))))
52 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
53 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
55 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
59 ;;; Pixmaps used in some of the tests
101 (defvar book-closed-xpm
126 (defvar mini-page-xpm
149 (defvar book-open-xpm
176 (defun create-bbox-in-frame (class frame-label spacing width height layout)
177 (declare (ignore width height))
178 (make-instance 'frame
180 :child (make-instance class
181 :border-width 5 :layout-style layout :spacing spacing
182 :child (make-instance 'button :stock "gtk-ok")
183 :child (make-instance 'button :stock "gtk-cancel")
184 :child (make-instance 'button :stock "gtk-help"))))
186 (define-toplevel create-button-box (window "Button Boxes")
187 (make-instance 'v-box
188 :parent window :border-width 10 :spacing 10 :show-all t
189 :child (make-instance 'frame
190 :label "Horizontal Button Boxes"
191 :child (make-instance 'v-box
192 :border-width 10 :spacing 10
195 (apply #'create-bbox-in-frame
197 '(("Spread" 40 85 20 :spread)
198 ("Edge" 40 85 20 :edge)
199 ("Start" 40 85 20 :start)
200 ("End" 40 85 20 :end)))))
201 :child (make-instance 'frame
202 :label "Vertical Button Boxes"
203 :child (make-instance 'h-box
204 :border-width 10 :spacing 10
207 (apply #'create-bbox-in-frame
209 '(("Spread" 30 85 20 :spread)
210 ("Edge" 30 85 20 :edge)
211 ("Start" 30 85 20 :start)
212 ("End" 30 85 20 :end)))))))
217 (define-simple-dialog create-buttons (dialog "Buttons")
218 (let ((table (make-instance 'table
219 :n-rows 3 :n-columns 3 :homogeneous nil
220 :row-spacing 5 :column-spacing 5 :border-width 10
224 collect (make-instance 'button
225 :label (format nil "button~D" (1+ n))))))
229 (let ((button (nth (+ (* 3 row) column) buttons))
230 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
231 (signal-connect button 'clicked
233 (if (widget-visible-p button+1)
234 (widget-hide button+1)
235 (widget-show button+1))))
236 (table-attach table button column (1+ column) row (1+ row)
237 :options '(:expand :fill)))))
238 (widget-show-all table)))
243 (define-simple-dialog create-calendar (dialog "Calendar")
244 (make-instance 'v-box
245 :parent dialog :border-width 10 :show-all t
246 :child (make-instance 'calendar)))
251 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
252 (make-instance 'v-box
253 :border-width 10 :spacing 10 :parent dialog :show-all t
256 collect (make-instance 'check-button
257 :label (format nil "Button~D" n)))))
263 (define-dialog create-color-selection (dialog "Color selection dialog"
264 'color-selection-dialog
265 :allow-grow nil :allow-shrink nil)
266 (with-slots (action-area colorsel) dialog
267 ;; This seg faults for some unknown reason
268 ;; (let ((button (make-instance 'check-button :label "Show Palette")))
269 ;; (dialog-add-action-widget dialog button
272 ;; (color-selection-has-palette-p colorsel)
273 ;; (toggle-button-active-p button)))))
275 (container-add action-area
276 (create-check-button "Show Opacity"
278 (setf (color-selection-has-opacity-control-p colorsel) state))))
280 (container-add action-area
281 (create-check-button "Show Palette"
283 (setf (color-selection-has-palette-p colorsel) state))))
285 (signal-connect dialog :ok
287 (let ((color (color-selection-current-color colorsel)))
288 (format t "Selected color: ~A~%" color)
289 (setf (color-selection-current-color colorsel) color)
290 (widget-hide dialog))))
292 (signal-connect dialog :cancel #'widget-destroy :object t)))
297 (defun clamp (n min-val max-val)
298 (declare (number n min-val max-val))
299 (max (min n max-val) min-val))
301 (defun set-cursor (spinner drawing-area label)
304 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
306 (setf (label-label label) (string-downcase cursor))
307 (setf (widget-cursor drawing-area) cursor)))
309 (defun cursor-expose (drawing-area event)
310 (declare (ignore event))
311 (multiple-value-bind (width height)
312 (widget-get-size-allocation drawing-area)
313 (let* ((window (widget-window drawing-area))
314 (style (widget-style drawing-area))
315 (white-gc (style-white-gc style))
316 (gray-gc (style-bg-gc style :normal))
317 (black-gc (style-black-gc style)))
318 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
319 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
321 (gdk:draw-rectangle window gray-gc t (floor width 3)
322 (floor height 3) (floor width 3)
326 (define-simple-dialog create-cursors (dialog "Cursors")
327 (let ((spinner (make-instance 'spin-button
328 :adjustment (adjustment-new
330 (1- (enum-int :last-cursor 'gdk:cursor-type))
332 (drawing-area (make-instance 'drawing-area
333 :width-request 80 :height-request 80
334 :events '(:exposure-mask :button-press-mask)))
335 (label (make-instance 'label :label "XXX")))
337 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
339 (signal-connect drawing-area 'button-press-event
341 (case (gdk:event-button event)
342 (1 (spin-button-spin spinner :step-forward 0.0))
343 (3 (spin-button-spin spinner :step-backward 0.0)))
346 (signal-connect drawing-area 'scroll-event
348 (case (gdk:event-direction event)
349 (:up (spin-button-spin spinner :step-forward 0.0))
350 (:down (spin-button-spin spinner :step-backward 0.0)))
353 (signal-connect spinner 'changed
355 (set-cursor spinner drawing-area label)))
357 (make-instance 'v-box
358 :parent dialog :border-width 10 :spacing 5 :show-all t
360 (make-instance 'h-box
363 (make-instance 'label :label "Cursor Value : ")
367 :child (make-instance 'frame
368 ; :shadow-type :etched-in
369 :label "Cursor Area" :label-xalign 0.5 :border-width 10
371 :child (list label :expand nil))
373 (widget-realize drawing-area)
374 (set-cursor spinner drawing-area label)))
380 (defun create-dialog ()
382 (setq dialog (make-instance 'dialog
383 :title "Dialog" :default-width 200
385 :button (list "gtk-ok" #'widget-destroy :object t)
386 :signal (list 'destroy
388 (setq dialog nil)))))
390 (let ((label (make-instance 'label
391 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
393 (signal-connect dialog "Toggle"
395 (if (widget-visible-p label)
397 (widget-show label))))))
399 (if (widget-visible-p dialog)
401 (widget-show dialog))))
406 (define-simple-dialog create-entry (dialog "Entry")
407 (let ((main (make-instance 'v-box
408 :border-width 10 :spacing 10 :parent dialog)))
410 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
411 (editable-select-region entry 0 5) ; this has no effect when
413 ;; (editable-insert-text entry "great " 6)
414 ;; (editable-delete-text entry 6 12)
416 (let ((combo (make-instance 'combo-box-entry
421 "item3 item3 item3 item3"
422 "item4 item4 item4 item4 item4"
423 "item5 item5 item5 item5 item5 item5"
424 "item6 item6 item6 item6 item6"
425 "item7 item7 item7 item7"
428 (with-slots (child) combo
429 (setf (editable-text child) "hello world")
430 (editable-select-region child 0)))
432 (flet ((create-check-button (label slot)
433 (make-instance 'check-button
434 :label label :active t :parent main
435 :signal (list 'toggled
437 (setf (slot-value entry slot)
438 (toggle-button-active-p button)))
441 (create-check-button "Editable" 'editable)
442 (create-check-button "Visible" 'visibility)
443 (create-check-button "Sensitive" 'sensitive)))
444 (widget-show-all main)))
449 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
450 (make-instance 'v-box
451 :parent dialog :spacing 5 :border-width 5 :show-all t
452 :child (create-label "Expander demo. Click on the triangle for details.")
453 :child (make-instance 'expander
455 :child (create-label "Details can be shown or hidden."))))
458 ;; File chooser dialog
460 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
461 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
462 (dialog-add-button dialog "gtk-ok"
464 (if (slot-boundp dialog 'filename)
465 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
466 (write-line "No files selected"))
467 (widget-destroy dialog))))
473 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
474 (make-instance 'v-box
476 :child (create-label "Above")
477 :child (make-instance 'h-separator)
478 :child (make-instance 'h-box
481 (make-instance 'handle-box
482 :child (create-toolbar window)
483 :signal (list 'child-attached
485 (format t "~A attached~%" child)))
486 :signal (list 'child-detached
488 (format t "~A detached~%" child))))
489 :expand nil :fill :nil))
490 :child (make-instance 'h-separator)
491 :child (create-label "Below")))
495 (define-toplevel create-image (window "Image")
496 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
501 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
502 (flet ((create-label-in-frame (frame-label label-text &rest args)
504 (make-instance 'frame
506 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
507 :fill nil :expand nil)))
508 (make-instance 'h-box
509 :spacing 5 :parent window
510 :child-args '(:fill nil :expand nil)
511 :child (make-instance 'v-box
513 :child (create-label-in-frame "Normal Label" "This is a Normal label")
514 :child (create-label-in-frame "Multi-line Label"
515 "This is a Multi-line label.
518 :child (create-label-in-frame "Left Justified Label"
519 "This is a Left-Justified
523 :child (create-label-in-frame "Right Justified Label"
524 "This is a Right-Justified
528 :child (make-instance 'v-box
530 :child (create-label-in-frame "Line wrapped label"
531 "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.
532 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
535 :child (create-label-in-frame "Filled, wrapped label"
536 "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.
537 This is a new paragraph.
538 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
539 :justify :fill :wrap t)
541 :child (create-label-in-frame "Underlined label"
542 "This label is underlined!
543 This one is underlined (こんにちは) in quite a funky fashion"
545 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
550 (defun layout-expose (layout event)
551 (when (eq (gdk:event-window event) (layout-bin-window layout))
552 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
553 (let ((imin (truncate gdk:x 10))
554 (imax (truncate (+ gdk:x gdk:width 9) 10))
555 (jmin (truncate gdk:y 10))
556 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
558 (let ((window (layout-bin-window layout))
559 (gc (style-black-gc (widget-style layout))))
561 for i from imin below imax
563 for j from jmin below jmax
564 unless (zerop (mod (+ i j) 2))
565 do (gdk:draw-rectangle
566 window gc t (* 10 i) (* 10 j)
567 (1+ (mod i 10)) (1+ (mod j 10)))))))))
570 (define-toplevel create-layout (window "Layout" :default-width 200
572 (let ((layout (make-instance 'layout
573 :parent (make-instance 'scrolled-window :parent window)
574 :width 1600 :height 128000 :events '(:exposure-mask)
575 :signal (list 'expose-event #'layout-expose :object t)
578 (with-slots (hadjustment vadjustment) layout
580 (adjustment-step-increment hadjustment) 10.0
581 (adjustment-step-increment vadjustment) 10.0))
585 (let ((text (format nil "Button ~D, ~D" i j)))
586 (make-instance (if (not (zerop (mod (+ i j) 2)))
589 :label text :parent (list layout :x (* j 100) :y (* i 100))))))
592 for i from 16 below 1280
593 do (let ((text (format nil "Button ~D, ~D" i 0)))
594 (make-instance (if (not (zerop (mod i 2)))
597 :label text :parent (list layout :x 0 :y (* i 100)))))))
603 (define-simple-dialog create-list (dialog "List" :default-height 400)
604 (let* ((store (make-instance 'list-store
605 :column-types '(string int boolean)
606 :column-names '(:foo :bar :baz)
607 :initial-content '(#("First" 12321 nil)
608 (:foo "Yeah" :baz t))))
609 (tree (make-instance 'tree-view :model store)))
612 with iter = (make-instance 'tree-iter)
614 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
616 (let ((column (make-instance 'tree-view-column :title "Column 1"))
617 (cell (make-instance 'cell-renderer-text)))
618 (cell-layout-pack column cell :expand t)
619 (cell-layout-add-attribute column cell 'text (column-index store :foo))
620 (tree-view-append-column tree column))
622 (let ((column (make-instance 'tree-view-column :title "Column 2"))
623 (cell (make-instance 'cell-renderer-text :background "orange")))
624 (cell-layout-pack column cell :expand t)
625 (cell-layout-add-attribute column cell 'text (column-index store :bar))
626 (tree-view-append-column tree column))
628 (let ((column (make-instance 'tree-view-column :title "Column 3"))
629 (cell (make-instance 'cell-renderer-text)))
630 (cell-layout-pack column cell :expand t)
631 (cell-layout-add-attribute column cell 'text (column-index store :baz))
632 (tree-view-append-column tree column))
634 (make-instance 'v-box
635 :parent dialog :border-width 10 :spacing 10 :show-all t
637 (make-instance 'h-box
639 :child (make-instance 'button
640 :label "Remove Selection"
641 :signal (list 'clicked
646 (make-instance 'tree-row-reference :model store :path path))
647 (tree-selection-get-selected-rows
648 (tree-view-selection tree)))))
650 #'(lambda (reference)
651 (list-store-remove store reference))
655 (make-instance 'h-box
657 :child (make-instance 'check-button
658 :label "Show Headers" :active t
659 :signal (list 'toggled
662 (tree-view-headers-visible-p tree)
663 (toggle-button-active-p button)))
665 :child (make-instance 'check-button
666 :label "Reorderable" :active nil
667 :signal (list 'toggled
670 (tree-view-reorderable-p tree)
671 (toggle-button-active-p button)))
674 (make-instance 'h-box
675 :child (make-instance 'label :label "Selection Mode: ")
676 :child (make-instance 'combo-box
677 :content '("Single" "Browse" "Multiple")
679 :signal (list 'changed
680 #'(lambda (combo-box)
683 (tree-view-selection tree))
685 #(:single :browse :multiple)
686 (combo-box-active combo-box))))
690 :child (make-instance 'scrolled-window
691 :child tree :hscrollbar-policy :automatic))))
696 (defun create-menu (depth tearoff)
697 (unless (zerop depth)
698 (let ((menu (make-instance 'menu)))
700 (let ((menu-item (make-instance 'tearoff-menu-item)))
701 (menu-shell-append menu menu-item)))
705 (make-instance 'radio-menu-item
706 :label (format nil "item ~2D - ~D" depth (1+ i)))))
708 (add-to-radio-group menu-item group)
709 (setq group menu-item))
710 (unless (zerop (mod depth 2))
711 (setf (check-menu-item-active-p menu-item) t))
712 (menu-shell-append menu menu-item)
714 (setf (widget-sensitive-p menu-item) nil))
715 (let ((submenu (create-menu (1- depth) t)))
717 (setf (menu-item-submenu menu-item) submenu))))))
721 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
722 (let* ((main (make-instance 'v-box :parent dialog))
723 ; (accel-group (make-instance 'accel-group))
724 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
725 ; (window-add-accel-group dialog accel-group)
727 (let ((menu-item (make-instance 'menu-item
728 :label (format nil "test~%line2"))))
729 (setf (menu-item-submenu menu-item) (create-menu 2 t))
730 (menu-shell-append menubar menu-item))
732 (let ((menu-item (make-instance 'menu-item :label "foo")))
733 (setf (menu-item-submenu menu-item) (create-menu 3 t))
734 (menu-shell-append menubar menu-item))
736 (let ((menu-item (make-instance 'menu-item :label "bar")))
737 (setf (menu-item-submenu menu-item) (create-menu 4 t))
738 (setf (menu-item-right-justified-p menu-item) t)
739 (menu-shell-append menubar menu-item))
741 (make-instance 'v-box
742 :spacing 10 :border-width 10 :parent main
743 :child (make-instance 'combo-box
747 collect (format nil "Item ~D" i))))
749 (widget-show-all main)))
754 (defun create-notebook-page (notebook page-num book-closed)
755 (let* ((title (format nil "Page ~D" page-num))
756 (page (make-instance 'frame :label title :border-width 10))
757 (v-box (make-instance 'v-box
758 :homogeneous t :border-width 10 :parent page)))
760 (make-instance 'h-box
761 :parent (list v-box :fill nil :padding 5) :homogeneous t
762 :child-args '(:padding 5)
763 :child (make-instance 'check-button
764 :label "Fill Tab" :active t
765 :signal (list 'toggled
768 (notebook-child-tab-fill-p page)
769 (toggle-button-active-p button)))
771 :child (make-instance 'check-button
773 :signal (list 'toggled
776 (notebook-child-tab-expand-p page)
777 (toggle-button-active-p button)))
779 :child (make-instance 'check-button
781 :signal (list 'toggled
784 (notebook-child-tab-pack page)
785 (if (toggle-button-active-p button)
789 :child (make-instance 'button
791 :signal (list 'clicked #'(lambda () (widget-hide page)))))
793 (let ((label-box (make-instance 'h-box
795 :child-args '(:expand nil)
796 :child (make-instance 'image :pixbuf book-closed)
797 :child (make-instance 'label :label title)))
798 (menu-box (make-instance 'h-box
800 :child-args '(:expand nil)
801 :child (make-instance 'image :pixbuf book-closed)
802 :child (make-instance 'label :label title))))
804 (widget-show-all page)
805 (notebook-append notebook page label-box menu-box))))
808 (define-simple-dialog create-notebook (dialog "Notebook")
809 (let ((main (make-instance 'v-box :parent dialog)))
810 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
811 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
812 (notebook (make-instance 'notebook
813 :border-width 10 :tab-pos :top :parent main)))
814 (flet ((set-image (page func pixbuf)
817 (first (container-children (funcall func notebook page))))
819 (signal-connect notebook 'switch-page
820 #'(lambda (pointer page)
821 (declare (ignore pointer))
822 (set-image page #'notebook-menu-label book-open)
823 (set-image page #'notebook-tab-label book-open)
824 (when (slot-boundp notebook 'current-page)
825 (let ((curpage (notebook-current-page notebook)))
826 (set-image curpage #'notebook-menu-label book-closed)
827 (set-image curpage #'notebook-tab-label book-closed))))))
828 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
830 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
832 (make-instance 'h-box
833 :spacing 5 :border-width 10
834 :parent (list main :expand nil)
835 :child-args '(:fill nil)
836 :child (make-instance 'check-button
838 :signal (list 'clicked
840 (if (toggle-button-active-p button)
841 (notebook-popup-enable notebook)
842 (notebook-popup-disable notebook)))
844 :child (make-instance 'check-button
845 :label "Homogeneous tabs"
846 :signal (list 'clicked
849 (notebook-homogeneous-p notebook)
850 (toggle-button-active-p button)))
853 (make-instance 'h-box
854 :spacing 5 :border-width 10
855 :parent (list main :expand nil)
856 :child-args '(:expand nil)
857 :child (make-instance 'label :label "Notebook Style: ")
858 :child (let ((scrollable-p nil))
859 (make-instance 'combo-box
860 :content '("Standard" "No tabs" "Scrollable") :active 0
861 :signal (list 'changed
862 #'(lambda (combo-box)
863 (case (combo-box-active combo-box)
865 (setf (notebook-show-tabs-p notebook) t)
867 (setq scrollable-p nil)
868 (setf (notebook-scrollable-p notebook) nil)
870 do (notebook-remove-page notebook 5))))
872 (setf (notebook-show-tabs-p notebook) nil)
874 (setq scrollable-p nil)
875 (setf (notebook-scrollable-p notebook) nil)
877 do (notebook-remove-page notebook 5))))
880 (setq scrollable-p t)
881 (setf (notebook-show-tabs-p notebook) t)
882 (setf (notebook-scrollable-p notebook) t)
883 (loop for i from 6 to 15
884 do (create-notebook-page notebook i book-closed))))))
886 :child (make-instance 'button
887 :label "Show all Pages"
888 :signal (list 'clicked
890 (map-container nil #'widget-show notebook)))))
892 (make-instance 'h-box
893 :spacing 5 :border-width 10
894 :parent (list main :expand nil)
895 :child (make-instance 'button
897 :signal (list 'clicked #'notebook-prev-page :object notebook))
898 :child (make-instance 'button
900 :signal (list 'clicked #'notebook-next-page :object notebook))
901 :child (make-instance 'button
903 :signal (let ((tab-pos 0))
906 (setq tab-pos (mod (1+ tab-pos) 4))
908 (notebook-tab-pos notebook)
909 (svref #(:top :right :bottom :left) tab-pos))))))))
910 (widget-show-all main)))
915 (defun toggle-resize (child)
916 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
918 (defun toggle-shrink (child)
919 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
921 (defun create-pane-options (paned frame-label label1 label2)
922 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
923 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
924 (let ((check-button (make-instance 'check-button :label "Resize")))
925 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
926 (signal-connect check-button 'toggled
927 #'toggle-resize :object (paned-child1 paned)))
928 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
929 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
930 (signal-connect check-button 'toggled
931 #'toggle-shrink :object (paned-child1 paned)))
933 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
934 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
935 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
936 (signal-connect check-button 'toggled
937 #'toggle-resize :object (paned-child2 paned)))
938 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
939 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
940 (signal-connect check-button 'toggled
941 #'toggle-shrink :object (paned-child2 paned)))
942 (make-instance 'frame :label frame-label :border-width 4 :child table)))
944 (define-toplevel create-panes (window "Panes")
945 (let* ((hpaned (make-instance 'h-paned
946 :child1 (make-instance 'frame
947 :width-request 60 :height-request 60
949 :child (make-instance 'button :label "Hi there"))
950 :child2 (make-instance 'frame
951 :width-request 80 :height-request 60
953 (vpaned (make-instance 'v-paned
956 :child2 (make-instance 'frame
957 :width-request 80 :height-request 60
960 (make-instance 'v-box
962 :child-args '(:expand nil)
963 :child (list vpaned :expand t)
964 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
965 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
970 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
971 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
972 (activity-mode-button (make-instance 'check-button
973 :label "Activity mode"))
974 (timer (timeout-add 100
976 (if (toggle-button-active-p activity-mode-button)
977 (progress-bar-pulse progress)
978 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
980 (progress-bar-fraction progress)
986 (make-instance 'v-box
987 :parent dialog :border-width 10 :spacing 10 :show-all t
989 :child activity-mode-button)
991 (signal-connect dialog 'destroy
992 #'(lambda () (when timer (timeout-remove timer))))))
997 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
998 (make-instance 'v-box
999 :parent dialog :border-width 10 :spacing 10 :show-all t
1000 :children (make-radio-group 'radio-button
1001 '((:label "button1") (:label "button2") (:label "button3"))
1007 (define-simple-dialog create-range-controls (dialog "Range controls")
1008 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1009 (make-instance 'v-box
1010 :parent dialog :border-width 10 :spacing 10 :show-all t
1011 :child (make-instance 'h-scale
1012 :width-request 150 :adjustment adjustment :inverted t
1013 :update-policy :delayed :digits 1 :draw-value t)
1014 :child (make-instance 'h-scrollbar
1015 :adjustment adjustment :update-policy :continuous))))
1020 (define-simple-dialog create-reparent (dialog "Reparent")
1021 (let ((main (make-instance 'h-box
1022 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1023 (label (make-instance 'label :label "Hello World")))
1025 (flet ((create-frame (title)
1026 (let* ((frame (make-instance 'frame :label title :parent main))
1027 (box (make-instance 'v-box
1028 :spacing 5 :border-width 5 :parent frame))
1029 (button (make-instance 'button
1030 :label "switch" :parent (list box :expand nil))))
1031 (signal-connect button 'clicked
1033 (widget-reparent label box)))
1036 (box-pack-start (create-frame "Frame 1") label nil t 0)
1037 (create-frame "Frame 2"))
1038 (widget-show-all main)))
1043 (define-toplevel create-rulers (window "Rulers"
1044 :default-width 300 :default-height 300
1045 ;; :events '(:pointer-motion-mask
1046 ;; :pointer-motion-hint-mask)
1049 (widget-events window)
1050 '(:pointer-motion-mask :pointer-motion-hint-mask))
1052 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1053 (h-ruler (make-instance 'h-ruler
1054 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1055 :position 0.0d0 :max-size 20.0d0))
1056 (v-ruler (make-instance 'v-ruler
1057 :lower 5.0d0 :upper 15.0d0
1058 :position 0.0d0 :max-size 20.0d0)))
1059 (signal-connect window 'motion-notify-event
1061 (widget-event h-ruler event)
1062 (widget-event v-ruler event)))
1063 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1064 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1069 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1071 :default-height 300)
1072 (let* ((scrolled-window
1073 (make-instance 'scrolled-window
1074 :parent dialog :border-width 10
1075 :vscrollbar-policy :automatic
1076 :hscrollbar-policy :automatic))
1078 (make-instance 'table
1079 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1080 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1081 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1083 (scrolled-window-add-with-viewport scrolled-window table)
1087 (make-instance 'toggle-button
1088 :label (format nil "button (~D,~D)~%" i j))))
1089 (table-attach table button i (1+ i) j (1+ j)))))
1090 (widget-show-all scrolled-window)))
1095 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1096 (let ((size-group (make-instance 'size-group)))
1097 (flet ((create-frame (label rows)
1098 (let ((table (make-instance 'table
1099 :n-rows (length rows) :n-columns 2 :homogeneous nil
1100 :row-spacing 5 :column-spacing 10 :border-width 5)))
1104 do (table-attach table
1105 (create-label (first row) :xalign 0 :yalign 1)
1106 0 1 i (1+ i) :x-options '(:expand :fill))
1107 (let ((combo (make-instance 'combo-box
1108 :content (rest row) :active 0)))
1109 (size-group-add-widget size-group combo)
1110 (table-attach table combo 1 2 i (1+ i))))
1111 (make-instance 'frame :label label :child table))))
1113 (make-instance 'v-box
1114 :parent dialog :border-width 5 :spacing 5 :show-all t
1115 :child (create-frame "Color Options"
1116 '(("Foreground" "Red" "Green" "Blue")
1117 ("Background" "Red" "Green" "Blue")))
1118 :child (create-frame "Line Options"
1119 '(("Dashing" "Solid" "Dashed" "Dotted")
1120 ("Line ends" "Square" "Round" "Arrow")))
1121 :child (create-check-button "Enable grouping"
1124 (size-group-mode size-group)
1125 (if active :horizontal :none)))
1131 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1133 ;; (make-instance 'window
1134 ;; :type type :x x :y y
1135 ;; :events '(:button-motion :pointer-motion-hint :button-press)))
1137 ;; (make-instance 'fixed
1138 ;; :parent window :width 100 :height 100)))
1140 ;; (widget-realize window)
1141 ;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1142 ;; (let ((pixmap (pixmap-new source mask))
1145 ;; (declare (fixnum x-offset y-offset))
1146 ;; (fixed-put fixed pixmap px py)
1147 ;; (widget-shape-combine-mask window mask px py)
1149 ;; (signal-connect window 'button-press-event
1150 ;; #'(lambda (event)
1151 ;; (when (typep event 'gdk:button-press-event)
1152 ;; (setq x-offset (truncate (gdk:event-x event)))
1153 ;; (setq y-offset (truncate (gdk:event-y event)))
1154 ;; (grab-add window)
1155 ;; (gdk:pointer-grab
1156 ;; (widget-window window) t
1157 ;; '(:button-release :button-motion :pointer-motion-hint)
1161 ;; (signal-connect window 'button-release-event
1162 ;; #'(lambda (event)
1163 ;; (declare (ignore event))
1164 ;; (grab-remove window)
1165 ;; (gdk:pointer-ungrab 0)
1168 ;; (signal-connect window 'motion-notify-event
1169 ;; #'(lambda (event)
1170 ;; (declare (ignore event))
1171 ;; (multiple-value-bind (win xp yp mask)
1172 ;; (gdk:window-get-pointer root-window)
1173 ;; (declare (ignore mask win) (fixnum xp yp))
1174 ;; (widget-set-uposition
1175 ;; window :x (- xp x-offset) :y (- yp y-offset)))
1177 ;; (signal-connect window 'destroy destroy)))
1179 ;; (widget-show-all window)
1183 ;; (let ((modeller nil)
1186 ;; (defun create-shapes ()
1187 ;; (let ((root-window (gdk:get-root-window)))
1188 ;; (if (not modeller)
1191 ;; (shape-create-icon
1192 ;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1193 ;; #'(lambda () (widget-destroyed modeller))))
1194 ;; (widget-destroy modeller))
1199 ;; (shape-create-icon
1200 ;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1201 ;; #'(lambda () (widget-destroyed sheets))))
1202 ;; (widget-destroy sheets))
1207 ;; (shape-create-icon
1208 ;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1209 ;; #'(lambda () (widget-destroyed rings))))
1210 ;; (widget-destroy rings)))))
1216 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1217 (let ((main (make-instance 'v-box
1218 :spacing 5 :border-width 10 :parent dialog)))
1220 (flet ((create-date-spinner (label adjustment shadow-type)
1221 (declare (ignore shadow-type))
1222 (make-instance 'v-box
1223 :child-args '(:expand nil)
1224 :child (make-instance 'label
1225 :label label :xalign 0.0 :yalign 0.5)
1226 :child (make-instance 'spin-button
1227 :adjustment adjustment :wrap t))))
1228 (make-instance 'frame
1229 :label "Not accelerated" :parent main
1230 :child (make-instance 'h-box
1232 :child-args '(:padding 5)
1233 :child (create-date-spinner "Day : "
1234 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1235 :child (create-date-spinner "Month : "
1236 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1237 :child (create-date-spinner "Year : "
1238 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1240 (let ((spinner1 (make-instance 'spin-button
1241 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1242 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1243 (spinner2 (make-instance 'spin-button
1244 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1245 :climb-rate 1.0 :wrap t))
1246 (value-label (make-instance 'label :label "0")))
1247 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1250 (spin-button-digits spinner1)
1251 (floor (spin-button-value spinner2)))))
1253 (make-instance 'frame
1254 :label "Accelerated" :parent main
1255 :child (make-instance 'v-box
1258 (make-instance 'h-box
1259 :child-args '(:padding 5)
1260 :child (make-instance 'v-box
1261 :child (make-instance 'label
1263 :xalign 0.0 :yalign 0.5)
1265 :child (make-instance 'v-box
1266 :child (make-instance 'label
1268 :xalign 0.0 :yalign 0.5)
1270 :expand nil :padding 5)
1271 :child (make-instance 'check-button
1272 :label "Snap to 0.5-ticks" :active t
1273 :signal (list 'clicked
1276 (spin-button-snap-to-ticks-p spinner1)
1277 (toggle-button-active-p button)))
1279 :child (make-instance 'check-button
1280 :label "Numeric only input mode" :active t
1281 :signal (list 'clicked
1284 (spin-button-numeric-p spinner1)
1285 (toggle-button-active-p button)))
1289 (make-instance 'h-box
1290 :child-args '(:padding 5)
1291 :child (make-instance 'button
1292 :label "Value as Int"
1293 :signal (list 'clicked
1296 (label-label value-label)
1298 (spin-button-value-as-int
1300 :child (make-instance 'button
1301 :label "Value as Float"
1302 :signal (list 'clicked
1305 (label-label value-label)
1307 (format nil "~~,~DF"
1308 (spin-button-digits spinner1))
1309 (spin-button-value spinner1)))))))
1310 :padding 5 :expand nil))))
1311 (widget-show-all main)))
1316 (define-toplevel create-statusbar (window "Statusbar")
1317 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1318 (close-button (create-button '("close" :can-default t)
1319 #'widget-destroy :object window))
1322 (signal-connect statusbar 'text-popped
1323 #'(lambda (context-id text)
1324 (declare (ignore context-id))
1325 (format nil "Popped: ~A~%" text)))
1327 (make-instance 'v-box
1329 :child (make-instance 'v-box
1330 :border-width 10 :spacing 10
1331 :child (create-button "push something"
1333 (statusbar-push statusbar 1
1334 (format nil "something ~D" (incf counter)))))
1335 :child (create-button "pop"
1337 (statusbar-pop statusbar 1)))
1338 :child (create-button "steal #4"
1340 (statusbar-remove statusbar 1 4)))
1341 :child (create-button "dump stack")
1342 :child (create-button "test contexts"))
1343 :child (list (make-instance 'h-separator) :expand nil)
1345 (make-instance 'v-box :border-width 10 :child close-button)
1347 :child (list statusbar :expand nil))
1349 (widget-grab-focus close-button)))
1354 (define-simple-dialog create-idle-test (dialog "Idle Test")
1355 (let ((label (make-instance 'label
1356 :label "count: 0" :xpad 10 :ypad 10))
1359 (signal-connect dialog 'destroy
1360 #'(lambda () (when idle (idle-remove idle))))
1362 (make-instance 'v-box
1363 :parent dialog :border-width 10 :spacing 10 :show-all t
1365 :child (make-instance 'frame
1366 :label "Label Container" :border-width 5
1367 :child(make-instance 'v-box
1368 :children (make-radio-group 'radio-button
1369 '((:label "Resize-Parent" :value :parent :active t)
1370 (:label "Resize-Queue" :value :queue)
1371 (:label "Resize-Immediate" :value :immediate))
1374 (container-resize-mode (dialog-action-area dialog)) mode))))))
1376 (dialog-add-button dialog "Start"
1383 (setf (label-label label) (format nil "count: ~D" count))
1386 (dialog-add-button dialog "Stop"
1390 (setq idle nil))))))
1396 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1397 (let ((label (make-instance 'label
1398 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1401 (signal-connect dialog 'destroy
1402 #'(lambda () (when timer (timeout-remove timer))))
1404 (dialog-add-button dialog "Start"
1411 (setf (label-label label) (format nil "count: ~D" count))
1414 (dialog-add-button dialog "Stop"
1417 (timeout-remove timer)
1418 (setq timer nil))))))
1423 (define-simple-dialog create-text (dialog "Text" :default-width 400
1424 :default-height 400)
1425 (let* ((text-view (make-instance 'text-view
1426 :border-width 10 :visible t :wrap-mode :word))
1427 (buffer (text-view-buffer text-view))
1430 (text-buffer-create-tag buffer "Bold" :weight :bold)
1431 (text-buffer-create-tag buffer "Italic" :style :italic)
1432 (text-buffer-create-tag buffer "Underline" :underline :single)
1434 (flet ((create-toggle-callback (tag-name)
1435 (let ((tag (text-tag-table-lookup
1436 (text-buffer-tag-table buffer) tag-name)))
1438 (unless (eq (and (find tag active-tags) t) active)
1441 (push tag active-tags)
1442 (setq active-tags (delete tag active-tags)))
1443 (multiple-value-bind (non-zero-p start end)
1444 (text-buffer-get-selection-bounds buffer)
1446 (text-buffer-apply-tag buffer tag start end)
1447 (text-buffer-remove-tag buffer tag start end))))))))
1450 (make-instance 'action-group
1451 :action (create-toggle-action
1452 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1453 (create-toggle-callback "Bold"))
1454 :action (create-toggle-action
1455 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1456 (create-toggle-callback "Italic"))
1457 :action (create-toggle-action
1458 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1459 (create-toggle-callback "Underline"))))
1460 (ui (make-instance 'ui-manager)))
1462 (ui-manager-insert-action-group ui actions)
1463 (ui-manager-add-ui ui
1464 '((:toolbar "ToolBar"
1466 (:toolitem "Italic")
1467 (:toolitem "Underline"))))
1469 ;; Callback to activate/deactivate toolbar buttons when cursor
1471 (signal-connect buffer 'mark-set
1472 #'(lambda (location mark)
1473 (declare (ignore mark))
1474 (text-tag-table-foreach (text-buffer-tag-table buffer)
1479 (text-iter-has-tag-p location tag)
1480 (not (text-iter-begins-tag-p location tag)))
1481 (text-iter-ends-tag-p location tag))))
1482 (unless (eq active (and (find tag active-tags) t))
1484 (push tag active-tags)
1485 (setq active-tags (delete tag active-tags)))
1487 (toggle-action-active-p
1488 (action-group-get-action actions (text-tag-name tag)))
1491 ;; Callback to apply active tags when a character is inserted
1492 (signal-connect buffer 'insert-text
1493 #'(lambda (iter &rest args)
1494 (declare (ignore args))
1495 (let ((before (text-buffer-get-iter-at-offset buffer
1496 (1- (text-iter-offset iter)))))
1498 for tag in active-tags
1499 do (text-buffer-apply-tag buffer tag before iter))))
1502 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1503 (container-add dialog text-view)))))
1508 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1509 (make-instance 'v-box
1510 :border-width 10 :spacing 10 :parent dialog :show-all t
1513 collect (make-instance 'toggle-button
1514 :label (format nil "Button~D" (1+ n))))))
1520 (defun create-toolbar (window)
1521 (make-instance 'toolbar
1522 :show-tooltips t :show-arrow nil
1524 ;; Insert a stock item
1525 :child (make-instance 'tool-button
1527 :tip-text "Destroy toolbar"
1528 :tip-private "Toolbar/Quit"
1529 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1531 :child (make-instance 'separator-tool-item)
1533 :child (make-instance 'tool-button
1534 :label "Horizontal" :stock "gtk-go-forward"
1535 :tip-text "Horizontal toolbar layout"
1536 :tip-private "Toolbar/Horizontal"
1537 :signal (list 'clicked
1539 (setf (toolbar-orientation toolbar) :horizontal))
1542 :child (make-instance 'tool-button
1543 :label "Vertical" :stock "gtk-go-down"
1544 :tip-text "Vertical toolbar layout"
1545 :tip-private "Toolbar/Vertical"
1546 :signal (list 'clicked
1548 (setf (toolbar-orientation toolbar) :vertical))
1551 :child (make-instance 'separator-tool-item)
1553 :children (make-radio-group 'radio-tool-button
1554 '((:label "Icons" :stock "gtk-justify-left"
1555 :tip-text "Only show toolbar icons"
1556 :tip-private "Toolbar/IconsOnly"
1558 (:label "Both" :stock "gtk-justify-center"
1559 :tip-text "Show toolbar icons and text"
1560 :tip-private "Toolbar/Both"
1561 :value :both :active t)
1562 (:label "Text" :stock "gtk-justify-right"
1563 :tip-text "Show toolbar text"
1564 :tip-private "Toolbar/TextOnly"
1567 #'(lambda (toolbar style)
1568 (setf (toolbar-style toolbar) style))
1571 :child (make-instance 'separator-tool-item)
1573 :child (make-instance 'tool-item
1574 :child (make-instance 'entry)
1575 :tip-text "This is an unusable GtkEntry"
1576 :tip-private "Hey don't click me!")
1578 :child (make-instance 'separator-tool-item)
1580 :child (make-instance 'tool-button
1581 :label "Enable" :stock "gtk-add"
1582 :tip-text "Enable tooltips"
1583 :tip-private "Toolbar/EnableTooltips"
1584 :signal (list 'clicked
1586 (setf (toolbar-show-tooltips-p toolbar) t))
1589 :child (make-instance 'tool-button
1590 :label "Disable" :stock "gtk-remove"
1591 :tip-text "Disable tooltips"
1592 :tip-private "Toolbar/DisableTooltips"
1593 :signal (list 'clicked
1595 (setf (toolbar-show-tooltips-p toolbar) nil))
1598 ;; :child (make-instance 'separator-tool-item)
1600 ;; :child (make-instance 'tool-button
1601 ;; :label "GTK" :icon #p"clg:examples;gtk.png"
1602 ;; :tip-text "GTK+ Logo"
1603 ;; :tip-private "Toolbar/GTK+")
1606 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1607 (container-add window (create-toolbar window)))
1613 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1614 (let ((tooltips (make-instance 'tooltips)))
1615 (flet ((create-button (label tip-text tip-private)
1616 (let ((button (make-instance 'toggle-button :label label)))
1617 (tooltips-set-tip tooltips button tip-text tip-private)
1619 (make-instance 'v-box
1620 :parent dialog :border-width 10 :spacing 10 :show-all t
1621 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1622 :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")))))
1627 (defvar *ui-description*
1628 '((:menubar "MenuBar"
1633 (:menuitem "SaveAs")
1636 (:menu "PreferencesMenu"
1642 (:menuitem "Square")
1643 (:menuitem "Rectangle")
1647 (:menuitem "About")))
1652 (:toolitem "Logo"))))
1654 (define-toplevel create-ui-manager (window "UI Manager")
1656 (make-instance 'action-group
1658 :action (create-action "FileMenu" nil "_File")
1659 :action (create-action "PreferencesMenu" nil "_Preferences")
1660 :action (create-action "ColorMenu" nil "_Color")
1661 :action (create-action "ShapeMenu" nil "_Shape")
1662 :action (create-action "HelpMenu" nil "_Help")
1663 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1664 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
1665 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1666 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1667 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
1668 :action (create-action "About" nil "_About" "<control>A" "About")
1669 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1670 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1671 :actions (create-radio-actions
1672 '(("Red" nil "_Red" "<control>R" "Blood")
1673 ("Green" nil "_Green" "<control>G" "Grass")
1674 ("Blue" nil "_Blue" "<control>B" "Sky"))
1676 :actions (create-radio-actions
1677 '(("Square" nil "_Square" "<control>S" "Square")
1678 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1679 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1680 (ui (make-instance 'ui-manager)))
1682 (ui-manager-insert-action-group ui actions)
1683 (ui-manager-add-ui ui *ui-description*)
1685 (window-add-accel-group window (ui-manager-accel-group ui))
1687 (make-instance 'v-box
1688 :parent window :show-all t
1690 (ui-manager-get-widget ui "/MenuBar")
1691 :expand nil :fill nil)
1693 (ui-manager-get-widget ui "/ToolBar")
1694 :expand nil :fill nil)
1695 :child (make-instance 'label
1696 :label "Type <alt> to start"
1697 :xalign 0.5 :yalign 0.5
1698 :width-request 200 :height-request 200))))
1704 (defun create-main-window ()
1705 ;; (rc-parse "clg:examples;testgtkrc2")
1706 ;; (rc-parse "clg:examples;testgtkrc")
1708 (let* ((button-specs
1709 '(("button box" create-button-box)
1710 ("buttons" create-buttons)
1711 ("calendar" create-calendar)
1712 ("check buttons" create-check-buttons)
1713 ("color selection" create-color-selection)
1714 ("cursors" create-cursors)
1715 ("dialog" create-dialog)
1717 ("entry" create-entry)
1718 ;; ("event watcher")
1719 ("enxpander" create-expander)
1720 ("file chooser" create-file-chooser)
1721 ;; ("font selection")
1722 ("handle box" create-handle-box)
1723 ("image" create-image)
1724 ("labels" create-labels)
1725 ("layout" create-layout)
1726 ("list" create-list)
1727 ("menus" create-menus)
1729 ("notebook" create-notebook)
1730 ("panes" create-panes)
1731 ("progress bar" create-progress-bar)
1732 ("radio buttons" create-radio-buttons)
1733 ("range controls" create-range-controls)
1735 ("reparent" create-reparent)
1736 ("rulers" create-rulers)
1737 ;; ("saved position")
1738 ("scrolled windows" create-scrolled-windows)
1739 ("size group" create-size-group)
1740 ;; ("shapes" create-shapes)
1741 ("spinbutton" create-spins)
1742 ("statusbar" create-statusbar)
1743 ("test idle" create-idle-test)
1744 ;; ("test mainloop")
1745 ;; ("test scrolling")
1746 ;; ("test selection")
1747 ("test timeout" create-timeout-test)
1748 ("text" create-text)
1749 ("toggle buttons" create-toggle-buttons)
1750 ("toolbar" create-toolbar-window)
1751 ("tooltips" create-tooltips)
1752 ;; ("tree" #|create-tree|#)
1753 ("UI manager" create-ui-manager)
1755 (main-window (make-instance 'window
1756 :title "testgtk.lisp" :name "main_window"
1757 :default-width 200 :default-height 400
1758 :allow-grow t :allow-shrink nil))
1759 (scrolled-window (make-instance 'scrolled-window
1760 :hscrollbar-policy :automatic
1761 :vscrollbar-policy :automatic
1763 (close-button (make-instance 'button
1764 :label "close" :can-default t
1765 :signal (list 'clicked #'widget-destroy
1766 :object main-window))))
1768 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1770 (window-icon main-window)
1771 (gdk:pixbuf-add-alpha icon t 254 254 252)))
1774 (make-instance 'v-box
1776 :child-args '(:expand nil)
1777 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1778 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1779 :child (list scrolled-window :expand t)
1780 :child (make-instance 'h-separator)
1781 :child (make-instance 'v-box
1782 :homogeneous nil :spacing 10 :border-width 10
1783 :child close-button))
1786 (make-instance 'v-box
1787 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1788 :children (mapcar #'(lambda (spec)
1789 (apply #'create-button spec))
1791 (scrolled-window-add-with-viewport scrolled-window content-box))
1793 (widget-grab-focus close-button)
1794 (widget-show-all main-window)
1798 (create-main-window)