1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
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.12 2004-12-20 00:56:11 espen Exp $
21 ;;; Some of the code in this file are really outdatet, but it is
22 ;;; still the most complete example of how to use the library
28 (defmacro define-toplevel (name (window title &rest initargs) &body body)
32 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
33 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
36 (if (not (widget-visible-p ,window))
37 (widget-show-all ,window)
38 (widget-hide ,window)))))
41 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
47 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
48 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
51 (if (not (widget-visible-p ,dialog))
53 (widget-hide ,dialog)))))
56 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
57 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
59 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
63 ;;; Pixmaps used in some of the tests
105 (defvar book-closed-xpm
130 (defvar mini-page-xpm
153 (defvar book-open-xpm
180 (defun create-bbox-in-frame (class frame-label spacing width height layout)
181 (declare (ignore width height))
182 (make-instance 'frame
184 :child (make-instance class
185 :border-width 5 :layout-style layout :spacing spacing
186 ; :child-min-width width :child-min-height height
187 :child (make-instance 'button :label "gtk-ok" :use-stock t)
188 :child (make-instance 'button :label "gtk-cancel" :use-stock t)
189 :child (make-instance 'button :label "gtk-help" :use-stock t))))
191 (define-toplevel create-button-box (window "Button Boxes")
192 (make-instance 'v-box
193 :parent window :border-width 10 :spacing 10 :show-all t
194 :child (make-instance 'frame
195 :label "Horizontal Button Boxes"
196 :child (make-instance 'v-box
197 :border-width 10 :spacing 10
200 (apply #'create-bbox-in-frame
202 '(("Spread" 40 85 20 :spread)
203 ("Edge" 40 85 20 :edge)
204 ("Start" 40 85 20 :start)
205 ("End" 40 85 20 :end)))))
206 :child (make-instance 'frame
207 :label "Vertical Button Boxes"
208 :child (make-instance 'h-box
209 :border-width 10 :spacing 10
212 (apply #'create-bbox-in-frame
214 '(("Spread" 30 85 20 :spread)
215 ("Edge" 30 85 20 :edge)
216 ("Start" 30 85 20 :start)
217 ("End" 30 85 20 :end)))))))
222 (define-simple-dialog create-buttons (dialog "Buttons")
223 (let ((table (make-instance 'table
224 :n-rows 3 :n-columns 3 :homogeneous nil
225 :row-spacing 5 :column-spacing 5 :border-width 10
229 collect (make-instance 'button
230 :label (format nil "button~D" (1+ n))))))
234 (let ((button (nth (+ (* 3 row) column) buttons))
235 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
236 (signal-connect button 'clicked
238 (if (widget-visible-p button+1)
239 (widget-hide button+1)
240 (widget-show button+1))))
241 (table-attach table button column (1+ column) row (1+ row)
242 :options '(:expand :fill)))))
243 (widget-show-all table)))
248 (define-simple-dialog create-calendar (dialog "Calendar")
249 (make-instance 'v-box
250 :parent dialog :border-width 10 :show-all t
251 :child (make-instance 'calendar)))
256 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
257 (make-instance 'v-box
258 :border-width 10 :spacing 10 :parent dialog :show-all t
261 collect (make-instance 'check-button
262 :label (format nil "Button~D" n)))))
268 (define-dialog create-color-selection (dialog "Color selection dialog"
269 'color-selection-dialog
270 :allow-grow nil :allow-shrink nil)
271 (with-slots (action-area colorsel) dialog
272 ;; This seg faults for some unknown reason
273 ;; (let ((button (make-instance 'check-button :label "Show Palette")))
274 ;; (dialog-add-action-widget dialog button
277 ;; (color-selection-has-palette-p colorsel)
278 ;; (toggle-button-active-p button)))))
280 (container-add action-area
281 (create-check-button "Show Opacity"
283 (setf (color-selection-has-opacity-control-p colorsel) state))))
285 (container-add action-area
286 (create-check-button "Show Palette"
288 (setf (color-selection-has-palette-p colorsel) state))))
290 (signal-connect dialog :ok
292 (let ((color (color-selection-current-color colorsel)))
293 (format t "Selected color: ~A~%" color)
294 (setf (color-selection-current-color colorsel) color)
295 (widget-hide dialog))))
297 (signal-connect dialog :cancel #'widget-destroy :object t)))
302 (defun clamp (n min-val max-val)
303 (declare (number n min-val max-val))
304 (max (min n max-val) min-val))
306 (defun set-cursor (spinner drawing-area label)
309 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
311 (setf (label-label label) (string-downcase cursor))
312 (setf (widget-cursor drawing-area) cursor)))
314 (defun cursor-expose (drawing-area event)
315 (declare (ignore event))
316 (multiple-value-bind (width height)
317 (drawing-area-get-size drawing-area)
318 (let* ((window (widget-window drawing-area))
319 (style (widget-style drawing-area))
320 (white-gc (style-white-gc style))
321 (gray-gc (style-bg-gc style :normal))
322 (black-gc (style-black-gc style)))
323 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
324 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
326 (gdk:draw-rectangle window gray-gc t (floor width 3)
327 (floor height 3) (floor width 3)
331 (define-simple-dialog create-cursors (dialog "Cursors")
332 (let ((spinner (make-instance 'spin-button
333 :adjustment (adjustment-new
335 (1- (enum-int :last-cursor 'gdk:cursor-type))
337 (drawing-area (make-instance 'drawing-area
338 :width-request 80 :height-request 80
339 :events '(:exposure-mask :button-press-mask)))
340 (label (make-instance 'label :label "XXX")))
342 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
344 (signal-connect drawing-area 'button-press-event
346 (case (gdk:event-button event)
347 (1 (spin-button-spin spinner :step-forward 0.0))
348 (3 (spin-button-spin spinner :step-backward 0.0)))
351 (signal-connect drawing-area 'scroll-event
353 (case (gdk:event-direction event)
354 (:up (spin-button-spin spinner :step-forward 0.0))
355 (:down (spin-button-spin spinner :step-backward 0.0)))
358 (signal-connect spinner 'changed
360 (set-cursor spinner drawing-area label)))
362 (make-instance 'v-box
363 :parent dialog :border-width 10 :spacing 5 :show-all t
365 (make-instance 'h-box
368 (make-instance 'label :label "Cursor Value : ")
372 :child (make-instance 'frame
373 ; :shadow-type :etched-in
374 :label "Cursor Area" :label-xalign 0.5 :border-width 10
376 :child (list label :expand nil))
378 (widget-realize drawing-area)
379 (set-cursor spinner drawing-area label)))
385 (defun create-dialog ()
387 (setq dialog (make-instance 'dialog
388 :title "Dialog" :default-width 200
390 :button (list "gtk-ok" #'widget-destroy :object t)
391 :signal (list 'destroy
393 (setq dialog nil)))))
395 (let ((label (make-instance 'label
396 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
398 (signal-connect dialog "Toggle"
400 (if (widget-visible-p label)
402 (widget-show label))))))
404 (if (widget-visible-p dialog)
406 (widget-show dialog))))
411 (define-simple-dialog create-entry (dialog "Entry")
412 (let ((main (make-instance 'v-box
413 :border-width 10 :spacing 10 :parent dialog)))
415 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
416 (editable-select-region entry 0 5) ; this has no effect when
418 ;; (editable-insert-text entry "great " 6)
419 ;; (editable-delete-text entry 6 12)
421 (let ((combo (make-instance 'combo-box-entry
426 "item3 item3 item3 item3"
427 "item4 item4 item4 item4 item4"
428 "item5 item5 item5 item5 item5 item5"
429 "item6 item6 item6 item6 item6"
430 "item7 item7 item7 item7"
433 (with-slots (child) combo
434 (setf (editable-text child) "hello world")
435 (editable-select-region child 0)))
437 (flet ((create-check-button (label slot)
438 (make-instance 'check-button
439 :label label :active t :parent main
440 :signal (list 'toggled
442 (setf (slot-value entry slot)
443 (toggle-button-active-p button)))
446 (create-check-button "Editable" 'editable)
447 (create-check-button "Visible" 'visibility)
448 (create-check-button "Sensitive" 'sensitive)))
449 (widget-show-all main)))
454 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
455 (make-instance 'v-box
456 :parent dialog :spacing 5 :border-width 5 :show-all t
457 :child (create-label "Expander demo. Click on the triangle for details.")
458 :child (make-instance 'expander
460 :child (create-label "Details can be shown or hidden."))))
463 ;; File chooser dialog
465 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
466 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
467 (dialog-add-button dialog "gtk-ok"
469 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
470 (widget-destroy dialog))))
476 ;; (defun create-handle-box-toolbar ()
477 ;; (let ((toolbar (toolbar-new :horizontal :both)))
478 ;; (toolbar-append-item
479 ;; toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
480 ;; :tooltip-text "Horizontal toolbar layout"
481 ;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
483 ;; (toolbar-append-item
484 ;; toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
485 ;; :tooltip-text "Vertical toolbar layout"
486 ;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
488 ;; (toolbar-append-space toolbar)
490 ;; (toolbar-append-item
491 ;; toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
492 ;; :tooltip-text "Only show toolbar icons"
493 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
495 ;; (toolbar-append-item
496 ;; toolbar "Text" (pixmap-new "clg:examples;test.xpm")
497 ;; :tooltip-text "Only show toolbar text"
498 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
500 ;; (toolbar-append-item
501 ;; toolbar "Both" (pixmap-new "clg:examples;test.xpm")
502 ;; :tooltip-text "Show toolbar icons and text"
503 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
505 ;; (toolbar-append-space toolbar)
507 ;; (toolbar-append-item
508 ;; toolbar "Small" (pixmap-new "clg:examples;test.xpm")
509 ;; :tooltip-text "Use small spaces"
510 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
512 ;; (toolbar-append-item
513 ;; toolbar "Big" (pixmap-new "clg:examples;test.xpm")
514 ;; :tooltip-text "Use big spaces"
515 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
517 ;; (toolbar-append-space toolbar)
519 ;; (toolbar-append-item
520 ;; toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
521 ;; :tooltip-text "Enable tooltips"
522 ;; :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
524 ;; (toolbar-append-item
525 ;; toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
526 ;; :tooltip-text "Disable tooltips"
527 ;; :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
529 ;; (toolbar-append-space toolbar)
531 ;; (toolbar-append-item
532 ;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
533 ;; :tooltip-text "Show borders"
534 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
536 ;; (toolbar-append-item
537 ;; toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
538 ;; :tooltip-text "Hide borders"
539 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
544 ;; (defun handle-box-child-signal (handle-box child action)
545 ;; (format t "~S: child ~S ~A~%" handle-box child action))
548 ;; (define-test-window create-handle-box "Handle Box Test"
549 ;; (setf (window-allow-grow-p window) t)
550 ;; (setf (window-allow-shrink-p window) t)
551 ;; (setf (window-auto-shrink-p window) nil)
552 ;; (setf (container-border-width window) 20)
553 ;; (let ((v-box (v-box-new nil 0)))
554 ;; (container-add window v-box)
556 ;; (container-add v-box (create-label "Above"))
557 ;; (container-add v-box (hseparator-new))
559 ;; (let ((hbox (hbox-new nil 10)))
560 ;; (container-add v-box hbox)
562 ;; (let ((handle-box (handle-box-new)))
563 ;; (box-pack-start hbox handle-box nil nil 0)
565 ;; handle-box 'child-attached
567 ;; (handle-box-child-signal handle-box child "attached")))
569 ;; handle-box 'child-detached
571 ;; (handle-box-child-signal handle-box child "detached")))
572 ;; (container-add handle-box (create-handle-box-toolbar)))
574 ;; (let ((handle-box (handle-box-new)))
575 ;; (box-pack-start hbox handle-box nil nil 0)
577 ;; handle-box 'child-attached
579 ;; (handle-box-child-signal handle-box child "attached")))
581 ;; handle-box 'child-detached
583 ;; (handle-box-child-signal handle-box child "detached")))
585 ;; (let ((handle-box2 (handle-box-new)))
586 ;; (container-add handle-box handle-box2)
588 ;; handle-box2 'child-attached
590 ;; (handle-box-child-signal handle-box child "attached")))
592 ;; handle-box2 'child-detached
594 ;; (handle-box-child-signal handle-box child "detached")))
595 ;; (container-add handle-box2 (create-label "Foo!")))))
597 ;; (container-add v-box (hseparator-new))
598 ;; (container-add v-box (create-label "Below"))))
602 (define-toplevel create-image (window "Image")
603 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
608 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
609 (flet ((create-label-in-frame (frame-label label-text &rest args)
611 (make-instance 'frame
613 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
614 :fill nil :expand nil)))
615 (make-instance 'h-box
616 :spacing 5 :parent window
617 :child-args '(:fill nil :expand nil)
618 :child (make-instance 'v-box
620 :child (create-label-in-frame "Normal Label" "This is a Normal label")
621 :child (create-label-in-frame "Multi-line Label"
622 "This is a Multi-line label.
625 :child (create-label-in-frame "Left Justified Label"
626 "This is a Left-Justified
630 :child (create-label-in-frame "Right Justified Label"
631 "This is a Right-Justified
635 :child (make-instance 'v-box
637 :child (create-label-in-frame "Line wrapped label"
638 "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.
639 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
642 :child (create-label-in-frame "Filled, wrapped label"
643 "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.
644 This is a new paragraph.
645 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
646 :justify :fill :wrap t)
648 :child (create-label-in-frame "Underlined label"
649 "This label is underlined!
650 This one is underlined (こんにちは) in quite a funky fashion"
652 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
657 (defun layout-expose (layout event)
658 (when (eq (gdk:event-window event) (layout-bin-window layout))
659 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
660 (let ((imin (truncate gdk:x 10))
661 (imax (truncate (+ gdk:x gdk:width 9) 10))
662 (jmin (truncate gdk:y 10))
663 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
665 (let ((window (layout-bin-window layout))
666 (gc (style-black-gc (widget-style layout))))
668 for i from imin below imax
670 for j from jmin below jmax
671 unless (zerop (mod (+ i j) 2))
672 do (gdk:draw-rectangle
673 window gc t (* 10 i) (* 10 j)
674 (1+ (mod i 10)) (1+ (mod j 10)))))))))
677 (define-toplevel create-layout (window "Layout" :default-width 200
679 (let ((layout (make-instance 'layout
680 :parent (make-instance 'scrolled-window :parent window)
681 :width 1600 :height 128000 :events '(:exposure-mask)
682 :signal (list 'expose-event #'layout-expose :object t)
685 (with-slots (hadjustment vadjustment) layout
687 (adjustment-step-increment hadjustment) 10.0
688 (adjustment-step-increment vadjustment) 10.0))
692 (let ((text (format nil "Button ~D, ~D" i j)))
693 (make-instance (if (not (zerop (mod (+ i j) 2)))
696 :label text :parent (list layout :x (* j 100) :y (* i 100))))))
699 for i from 16 below 1280
700 do (let ((text (format nil "Button ~D, ~D" i 0)))
701 (make-instance (if (not (zerop (mod i 2)))
704 :label text :parent (list layout :x 0 :y (* i 100)))))))
710 (define-simple-dialog create-list (dialog "List" :default-height 400)
711 (let* ((store (make-instance 'list-store
712 :column-types '(string int boolean)
713 :column-names '(:foo :bar :baz)
714 :initial-content '(#("First" 12321 nil)
715 (:foo "Yeah" :baz t))))
716 (tree (make-instance 'tree-view :model store)))
719 with iter = (make-instance 'tree-iter)
721 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
723 (let ((column (make-instance 'tree-view-column :title "Column 1"))
724 (cell (make-instance 'cell-renderer-text)))
725 (cell-layout-pack column cell :expand t)
726 (cell-layout-add-attribute column cell 'text (column-index store :foo))
727 (tree-view-append-column tree column))
729 (let ((column (make-instance 'tree-view-column :title "Column 2"))
730 (cell (make-instance 'cell-renderer-text :background "orange")))
731 (cell-layout-pack column cell :expand t)
732 (cell-layout-add-attribute column cell 'text (column-index store :bar))
733 (tree-view-append-column tree column))
735 (let ((column (make-instance 'tree-view-column :title "Column 3"))
736 (cell (make-instance 'cell-renderer-text)))
737 (cell-layout-pack column cell :expand t)
738 (cell-layout-add-attribute column cell 'text (column-index store :baz))
739 (tree-view-append-column tree column))
741 (make-instance 'v-box
742 :parent dialog :border-width 10 :spacing 10 :show-all t
744 (make-instance 'h-box
746 :child (make-instance 'button
747 :label "Remove Selection"
748 :signal (list 'clicked
753 (make-instance 'tree-row-reference :model store :path path))
754 (tree-selection-get-selected-rows
755 (tree-view-selection tree)))))
757 #'(lambda (reference)
758 (list-store-remove store reference))
762 (make-instance 'h-box
764 :child (make-instance 'check-button
765 :label "Show Headers" :active t
766 :signal (list 'toggled
769 (tree-view-headers-visible-p tree)
770 (toggle-button-active-p button)))
772 :child (make-instance 'check-button
773 :label "Reorderable" :active nil
774 :signal (list 'toggled
777 (tree-view-reorderable-p tree)
778 (toggle-button-active-p button)))
781 (make-instance 'h-box
782 :child (make-instance 'label :label "Selection Mode: ")
783 :child (make-instance 'combo-box
784 :content '("Single" "Browse" "Multiple")
786 :signal (list 'changed
787 #'(lambda (combo-box)
790 (tree-view-selection tree))
792 #(:single :browse :multiple)
793 (combo-box-active combo-box))))
797 :child (make-instance 'scrolled-window
798 :child tree :hscrollbar-policy :automatic))))
803 (defun create-menu (depth tearoff)
804 (unless (zerop depth)
805 (let ((menu (make-instance 'menu)))
807 (let ((menu-item (make-instance 'tearoff-menu-item)))
808 (menu-shell-append menu menu-item)))
812 (make-instance 'radio-menu-item
813 :label (format nil "item ~2D - ~D" depth (1+ i)))))
815 (radio-menu-item-add-to-group menu-item group)
816 (setq group menu-item))
817 (unless (zerop (mod depth 2))
818 (setf (check-menu-item-active-p menu-item) t))
819 (menu-shell-append menu menu-item)
821 (setf (widget-sensitive-p menu-item) nil))
822 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
826 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
827 (let* ((main (make-instance 'v-box :parent dialog))
828 ; (accel-group (make-instance 'accel-group))
829 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
830 ; (accel-group-attach accel-group window)
832 (let ((menu-item (make-instance 'menu-item
833 :label (format nil "test~%line2"))))
834 (setf (menu-item-submenu menu-item) (create-menu 2 t))
835 (menu-shell-append menubar menu-item))
837 (let ((menu-item (make-instance 'menu-item :label "foo")))
838 (setf (menu-item-submenu menu-item) (create-menu 3 t))
839 (menu-shell-append menubar menu-item))
841 (let ((menu-item (make-instance 'menu-item :label "bar")))
842 (setf (menu-item-submenu menu-item) (create-menu 4 t))
843 (setf (menu-item-right-justified-p menu-item) t)
844 (menu-shell-append menubar menu-item))
846 (make-instance 'v-box
847 :spacing 10 :border-width 10 :parent main
848 :child (make-instance 'combo-box
852 collect (format nil "Item ~D" i))))
854 (widget-show-all main)))
859 (defun create-notebook-page (notebook page-num)
860 (let* ((title (format nil "Page ~D" page-num))
861 (page (make-instance 'frame :label title :border-width 10))
862 (v-box (make-instance 'v-box
863 :homogeneous t :border-width 10 :parent page)))
865 (make-instance 'h-box
866 :parent (list v-box :fill nil :padding 5) :homogeneous t
867 :child-args '(:padding 5)
868 :child (make-instance 'check-button
869 :label "Fill Tab" :active t
870 :signal (list 'toggled
873 (notebook-child-tab-fill-p page)
874 (toggle-button-active-p button)))
876 :child (make-instance 'check-button
878 :signal (list 'toggled
881 (notebook-child-tab-expand-p page)
882 (toggle-button-active-p button)))
884 :child (make-instance 'check-button
886 :signal (list 'toggled
889 (notebook-child-tab-pack page)
890 (if (toggle-button-active-p button)
894 :child (make-instance 'button
896 :signal (list 'clicked #'(lambda () (widget-hide page)))))
898 (let ((label-box (make-instance 'h-box
900 :child-args '(:expand nil)
901 :child (make-instance 'image :pixmap book-closed-xpm)
902 :child (make-instance 'label :label title)))
903 (menu-box (make-instance 'h-box
905 :child-args '(:expand nil)
906 :child (make-instance 'image :pixmap book-closed-xpm)
907 :child (make-instance 'label :label title))))
909 (widget-show-all page)
910 (notebook-append notebook page label-box menu-box))))
913 (define-simple-dialog create-notebook (dialog "Notebook")
914 (let ((main (make-instance 'v-box :parent dialog)))
915 (let ((notebook (make-instance 'notebook
916 :border-width 10 :tab-pos :top :parent main)))
917 (flet ((set-image (page func xpm)
918 (image-set-from-pixmap-data
919 (first (container-children (funcall func notebook page)))
921 (signal-connect notebook 'switch-page
922 #'(lambda (pointer page)
923 (declare (ignore pointer))
924 (unless (eq page (notebook-current-page-num notebook))
925 (set-image page #'notebook-menu-label book-open-xpm)
926 (set-image page #'notebook-tab-label book-open-xpm)
928 (let ((curpage (notebook-current-page notebook)))
930 (set-image curpage #'notebook-menu-label book-closed-xpm)
931 (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
932 (loop for i from 1 to 5 do (create-notebook-page notebook i))
934 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
936 (make-instance 'h-box
937 :spacing 5 :border-width 10
938 :parent (list main :expand nil)
939 :child-args '(:fill nil)
940 :child (make-instance 'check-button
942 :signal (list 'clicked
944 (if (toggle-button-active-p button)
945 (notebook-popup-enable notebook)
946 (notebook-popup-disable notebook)))
948 :child (make-instance 'check-button
949 :label "Homogeneous tabs"
950 :signal (list 'clicked
953 (notebook-homogeneous-p notebook)
954 (toggle-button-active-p button)))
957 (make-instance 'h-box
958 :spacing 5 :border-width 10
959 :parent (list main :expand nil)
960 :child-args '(:expand nil)
961 :child (make-instance 'label :label "Notebook Style: ")
962 :child (let ((scrollable-p nil))
963 ;; option menu is deprecated, we should use combo-box
964 (make-instance 'combo-box
965 :content '("Standard" "No tabs" "Scrollable") :active 0
966 :signal (list 'changed
967 #'(lambda (combo-box)
968 (case (combo-box-active combo-box)
970 (setf (notebook-show-tabs-p notebook) t)
972 (setq scrollable-p nil)
973 (setf (notebook-scrollable-p notebook) nil)
975 do (notebook-remove-page notebook 5))))
977 (setf (notebook-show-tabs-p notebook) nil)
979 (setq scrollable-p nil)
980 (setf (notebook-scrollable-p notebook) nil)
982 do (notebook-remove-page notebook 5))))
985 (setq scrollable-p t)
986 (setf (notebook-show-tabs-p notebook) t)
987 (setf (notebook-scrollable-p notebook) t)
988 (loop for i from 6 to 15
989 do (create-notebook-page notebook i))))))
991 :child (make-instance 'button
992 :label "Show all Pages"
993 :signal (list 'clicked
995 (map-container nil #'widget-show notebook)))))
997 (make-instance 'h-box
998 :spacing 5 :border-width 10
999 :parent (list main :expand nil)
1000 :child (make-instance 'button
1002 :signal (list 'clicked #'notebook-prev-page :object notebook))
1003 :child (make-instance 'button
1005 :signal (list 'clicked #'notebook-next-page :object notebook))
1006 :child (make-instance 'button
1008 :signal (let ((tab-pos 0))
1011 (setq tab-pos (mod (1+ tab-pos) 4))
1013 (notebook-tab-pos notebook)
1014 (svref #(:top :right :bottom :left) tab-pos))))))))
1015 (widget-show-all main)))
1020 (defun toggle-resize (child)
1021 (let* ((paned (widget-parent child))
1022 (is-child1-p (eq child (paned-child1 paned))))
1023 (multiple-value-bind (child resize shrink)
1025 (paned-child1 paned)
1026 (paned-child2 paned))
1027 (container-remove paned child)
1029 (paned-pack1 paned child (not resize) shrink)
1030 (paned-pack2 paned child (not resize) shrink)))))
1032 (defun toggle-shrink (child)
1033 (let* ((paned (widget-parent child))
1034 (is-child1-p (eq child (paned-child1 paned))))
1035 (multiple-value-bind (child resize shrink)
1037 (paned-child1 paned)
1038 (paned-child2 paned))
1039 (container-remove paned child)
1041 (paned-pack1 paned child resize (not shrink))
1042 (paned-pack2 paned child resize (not shrink))))))
1044 (defun create-pane-options (paned frame-label label1 label2)
1045 (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
1046 (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
1049 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1050 (let ((check-button (make-instance 'check-button :label "Resize")))
1051 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1053 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1054 (let ((check-button (make-instance 'check-button :label "Shrink")))
1055 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1056 (setf (toggle-button-active-p check-button) t)
1058 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1060 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1061 (let ((check-button (make-instance 'check-button :label "Resize")))
1062 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1063 (setf (toggle-button-active-p check-button) t)
1065 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1066 (let ((check-button (make-instance 'check-button :label "Shrink")))
1067 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1068 (setf (toggle-button-active-p check-button) t)
1070 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1073 (define-toplevel create-panes (window "Panes")
1074 (let* ((hpaned (make-instance 'h-paned
1075 :child1 (make-instance 'frame
1076 :width-request 60 :height-request 60
1078 :child (make-instance 'buttun :label "Hi there"))
1079 :child2 (make-instance 'frame
1080 :width-request 80 :height-request 60
1082 (vpaned (make-instance 'v-paned
1085 :child2 (make-instance 'frame
1086 :width-request 80 :height-request 60
1087 :shadow-type :in))))
1089 (make-instance 'v-box
1091 :child-args '(:expand nil)
1092 :child (list vpaned :expand t)
1093 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1094 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1104 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1105 (make-instance 'v-box
1106 :parent dialog :border-width 10 :spacing 10 :show-all t
1107 :children (create-radio-button-group '("button1" "button2" "button3") 1)))
1112 (define-simple-dialog create-range-controls (dialog "Range controls")
1113 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1114 (make-instance 'v-box
1115 :parent dialog :border-width 10 :spacing 10 :show-all t
1116 :child (make-instance 'h-scale
1117 :width-request 150 :adjustment adjustment :inverted t
1118 :update-policy :delayed :digits 1 :draw-value t)
1119 :child (make-instance 'h-scrollbar
1120 :adjustment adjustment :update-policy :continuous))))
1125 (define-simple-dialog create-reparent (dialog "Reparent")
1126 (let ((main (make-instance 'h-box
1127 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1128 (label (make-instance 'label :label "Hellow World")))
1130 (flet ((create-frame (title)
1131 (let* ((frame (make-instance 'frame :label title :parent main))
1132 (box (make-instance 'v-box
1133 :spacing 5 :border-width 5 :parent frame))
1134 (button (make-instance 'button
1135 :label "switch" :parent (list box :expand nil))))
1136 (signal-connect button 'clicked
1138 (widget-reparent label box)))
1141 (box-pack-start (create-frame "Frame 1") label nil t 0)
1142 (create-frame "Frame 2"))
1143 (widget-show-all main)))
1148 (define-toplevel create-rulers (window "Rulers"
1149 :default-width 300 :default-height 300
1150 ;; :events '(:pointer-motion-mask
1151 ;; :pointer-motion-hint-mask)
1154 (widget-events window)
1155 '(:pointer-motion-mask :pointer-motion-hint-mask))
1157 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1158 (h-ruler (make-instance 'h-ruler
1159 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1160 :position 0.0d0 :max-size 20.0d0))
1161 (v-ruler (make-instance 'v-ruler
1162 :lower 5.0d0 :upper 15.0d0
1163 :position 0.0d0 :max-size 20.0d0)))
1164 (signal-connect window 'motion-notify-event
1166 (widget-event h-ruler event)
1167 (widget-event v-ruler event)))
1168 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1169 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1174 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1176 :default-height 300)
1177 (let* ((scrolled-window
1178 (make-instance 'scrolled-window
1179 :parent dialog :border-width 10
1180 :vscrollbar-policy :automatic
1181 :hscrollbar-policy :automatic))
1183 (make-instance 'table
1184 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1185 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1186 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1188 (scrolled-window-add-with-viewport scrolled-window table)
1192 (make-instance 'toggle-button
1193 :label (format nil "button (~D,~D)~%" i j))))
1194 (table-attach table button i (1+ i) j (1+ j)))))
1195 (widget-show-all scrolled-window)))
1200 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1201 (let ((size-group (make-instance 'size-group)))
1202 (flet ((create-frame (label rows)
1203 (let ((table (make-instance 'table
1204 :n-rows (length rows) :n-columns 2 :homogeneous nil
1205 :row-spacing 5 :column-spacing 10 :border-width 5)))
1209 do (table-attach table
1210 (create-label (first row) :xalign 0 :yalign 1)
1211 0 1 i (1+ i) :x-options '(:expand :fill))
1212 (let ((combo (make-instance 'combo-box
1213 :content (rest row) :active 0)))
1214 (size-group-add-widget size-group combo)
1215 (table-attach table combo 1 2 i (1+ i))))
1216 (make-instance 'frame :label label :child table))))
1218 (make-instance 'v-box
1219 :parent dialog :border-width 5 :spacing 5 :show-all t
1220 :child (create-frame "Color Options"
1221 '(("Foreground" "Red" "Green" "Blue")
1222 ("Background" "Red" "Green" "Blue")))
1223 :child (create-frame "Line Options"
1224 '(("Dashing" "Solid" "Dashed" "Dotted")
1225 ("Line ends" "Square" "Round" "Arrow")))
1226 :child (create-check-button "Enable grouping"
1229 (size-group-mode size-group)
1230 (if active :horizontal :none)))
1236 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1238 ;; (make-instance 'window
1239 ;; :type type :x x :y y
1240 ;; :events '(:button-motion :pointer-motion-hint :button-press)))
1242 ;; (make-instance 'fixed
1243 ;; :parent window :width 100 :height 100)))
1245 ;; (widget-realize window)
1246 ;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1247 ;; (let ((pixmap (pixmap-new source mask))
1250 ;; (declare (fixnum x-offset y-offset))
1251 ;; (fixed-put fixed pixmap px py)
1252 ;; (widget-shape-combine-mask window mask px py)
1254 ;; (signal-connect window 'button-press-event
1255 ;; #'(lambda (event)
1256 ;; (when (typep event 'gdk:button-press-event)
1257 ;; (setq x-offset (truncate (gdk:event-x event)))
1258 ;; (setq y-offset (truncate (gdk:event-y event)))
1259 ;; (grab-add window)
1260 ;; (gdk:pointer-grab
1261 ;; (widget-window window) t
1262 ;; '(:button-release :button-motion :pointer-motion-hint)
1266 ;; (signal-connect window 'button-release-event
1267 ;; #'(lambda (event)
1268 ;; (declare (ignore event))
1269 ;; (grab-remove window)
1270 ;; (gdk:pointer-ungrab 0)
1273 ;; (signal-connect window 'motion-notify-event
1274 ;; #'(lambda (event)
1275 ;; (declare (ignore event))
1276 ;; (multiple-value-bind (win xp yp mask)
1277 ;; (gdk:window-get-pointer root-window)
1278 ;; (declare (ignore mask win) (fixnum xp yp))
1279 ;; (widget-set-uposition
1280 ;; window :x (- xp x-offset) :y (- yp y-offset)))
1282 ;; (signal-connect window 'destroy destroy)))
1284 ;; (widget-show-all window)
1288 ;; (let ((modeller nil)
1291 ;; (defun create-shapes ()
1292 ;; (let ((root-window (gdk:get-root-window)))
1293 ;; (if (not modeller)
1296 ;; (shape-create-icon
1297 ;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1298 ;; #'(lambda () (widget-destroyed modeller))))
1299 ;; (widget-destroy modeller))
1304 ;; (shape-create-icon
1305 ;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1306 ;; #'(lambda () (widget-destroyed sheets))))
1307 ;; (widget-destroy sheets))
1312 ;; (shape-create-icon
1313 ;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1314 ;; #'(lambda () (widget-destroyed rings))))
1315 ;; (widget-destroy rings)))))
1321 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1322 (let ((main (make-instance 'v-box
1323 :spacing 5 :border-width 10 :parent dialog)))
1325 (flet ((create-date-spinner (label adjustment shadow-type)
1326 (declare (ignore shadow-type))
1327 (make-instance 'v-box
1328 :child-args '(:expand nil)
1329 :child (make-instance 'label
1330 :label label :xalign 0.0 :yalign 0.5)
1331 :child (make-instance 'spin-button
1332 :adjustment adjustment :wrap t))))
1333 (make-instance 'frame
1334 :label "Not accelerated" :parent main
1335 :child (make-instance 'h-box
1337 :child-args '(:padding 5)
1338 :child (create-date-spinner "Day : "
1339 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1340 :child (create-date-spinner "Month : "
1341 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1342 :child (create-date-spinner "Year : "
1343 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1345 (let ((spinner1 (make-instance 'spin-button
1346 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1347 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1348 (spinner2 (make-instance 'spin-button
1349 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1350 :climb-rate 1.0 :wrap t))
1351 (value-label (make-instance 'label :label "0")))
1352 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1355 (spin-button-digits spinner1)
1356 (floor (spin-button-value spinner2)))))
1358 (make-instance 'frame
1359 :label "Accelerated" :parent main
1360 :child (make-instance 'v-box
1363 (make-instance 'h-box
1364 :child-args '(:padding 5)
1365 :child (make-instance 'v-box
1366 :child (make-instance 'label
1368 :xalign 0.0 :yalign 0.5)
1370 :child (make-instance 'v-box
1371 :child (make-instance 'label
1373 :xalign 0.0 :yalign 0.5)
1375 :expand nil :padding 5)
1376 :child (make-instance 'check-button
1377 :label "Snap to 0.5-ticks" :active t
1378 :signal (list 'clicked
1381 (spin-button-snap-to-ticks-p spinner1)
1382 (toggle-button-active-p button)))
1384 :child (make-instance 'check-button
1385 :label "Numeric only input mode" :active t
1386 :signal (list 'clicked
1389 (spin-button-numeric-p spinner1)
1390 (toggle-button-active-p button)))
1394 (make-instance 'h-box
1395 :child-args '(:padding 5)
1396 :child (make-instance 'button
1397 :label "Value as Int"
1398 :signal (list 'clicked
1401 (label-label value-label)
1403 (spin-button-value-as-int
1405 :child (make-instance 'button
1406 :label "Value as Float"
1407 :signal (list 'clicked
1410 (label-label value-label)
1412 (format nil "~~,~DF"
1413 (spin-button-digits spinner1))
1414 (spin-button-value spinner1)))))))
1415 :padding 5 :expand nil))))
1416 (widget-show-all main)))
1421 (define-toplevel create-statusbar (window "Statusbar")
1422 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1423 (close-button (create-button '("close" :can-default t)
1424 #'widget-destroy :object window))
1427 (signal-connect statusbar 'text-popped
1428 #'(lambda (context-id text)
1429 (declare (ignore context-id))
1430 (format nil "Popped: ~A~%" text)))
1432 (make-instance 'v-box
1434 :child (make-instance 'v-box
1435 :border-width 10 :spacing 10
1436 :child (create-button "push something"
1438 (statusbar-push statusbar 1
1439 (format nil "something ~D" (incf counter)))))
1440 :child (create-button "pop"
1442 (statusbar-pop statusbar 1)))
1443 :child (create-button "steal #4"
1445 (statusbar-remove statusbar 1 4)))
1446 :child (create-button "dump stack")
1447 :child (create-button "test contexts"))
1448 :child (list (make-instance 'h-separator) :expand nil)
1450 (make-instance 'v-box :border-width 10 :child close-button)
1452 :child (list statusbar :expand nil))
1454 (widget-grab-focus close-button)))
1459 (define-simple-dialog create-idle-test (dialog "Idle Test")
1460 (let ((label (make-instance 'label
1461 :label "count: 0" :xpad 10 :ypad 10))
1464 (signal-connect dialog 'destroy
1465 #'(lambda () (when idle (idle-remove idle))))
1467 (make-instance 'v-box
1468 :parent dialog :border-width 10 :spacing 10 :show-all t
1470 :child (make-instance 'frame
1471 :label "Label Container" :border-width 5
1472 :child(make-instance 'v-box
1473 :children (create-radio-button-group
1474 '(("Resize-Parent" :parent)
1475 ("Resize-Queue" :queue)
1476 ("Resize-Immediate" :immediate))
1480 (container-resize-mode (dialog-action-area dialog)) mode))))))
1482 (dialog-add-button dialog "Start"
1489 (setf (label-label label) (format nil "count: ~D" count))
1492 (dialog-add-button dialog "Stop"
1496 (setq idle nil))))))
1502 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1503 (let ((label (make-instance 'label
1504 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1507 (signal-connect dialog 'destroy
1508 #'(lambda () (when timer (timeout-remove timer))))
1510 (dialog-add-button dialog "Start"
1517 (setf (label-label label) (format nil "count: ~D" count))
1520 (dialog-add-button dialog "Stop"
1523 (timeout-remove timer)
1524 (setq timer nil))))))
1529 (define-simple-dialog create-text (dialog "Text" :default-width 400
1530 :default-height 400)
1531 (let* ((text-view (make-instance 'text-view
1532 :border-width 10 :visible t :wrap-mode :word))
1533 (buffer (text-view-buffer text-view))
1536 (text-buffer-create-tag buffer "Bold" :weight :bold)
1537 (text-buffer-create-tag buffer "Italic" :style :italic)
1538 (text-buffer-create-tag buffer "Underline" :underline :single)
1540 (flet ((create-toggle-callback (tag-name)
1541 (let ((tag (text-tag-table-lookup
1542 (text-buffer-tag-table buffer) tag-name)))
1544 (unless (eq (and (find tag active-tags) t) active)
1547 (push tag active-tags)
1548 (setq active-tags (delete tag active-tags)))
1549 (multiple-value-bind (start end)
1550 (text-buffer-get-selection-bounds buffer)
1552 (text-buffer-apply-tag buffer tag start end)
1553 (text-buffer-remove-tag buffer tag start end))))))))
1556 (make-instance 'action-group
1557 :action (create-toggle-action
1558 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1559 (create-toggle-callback "Bold"))
1560 :action (create-toggle-action
1561 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1562 (create-toggle-callback "Italic"))
1563 :action (create-toggle-action
1564 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1565 (create-toggle-callback "Underline"))))
1566 (ui (make-instance 'ui-manager)))
1568 (ui-manager-insert-action-group ui actions)
1569 (ui-manager-add-ui ui
1570 '((:toolbar "ToolBar"
1572 (:toolitem "Italic")
1573 (:toolitem "Underline"))))
1575 ;; Callback to activate/deactivate toolbar buttons when cursor
1577 (signal-connect buffer 'mark-set
1578 #'(lambda (location mark)
1579 (declare (ignore mark))
1580 (text-tag-table-foreach (text-buffer-tag-table buffer)
1585 (text-iter-has-tag-p location tag)
1586 (not (text-iter-begins-tag-p location tag)))
1587 (text-iter-ends-tag-p location tag))))
1588 (unless (eq active (and (find tag active-tags) t))
1590 (push tag active-tags)
1591 (setq active-tags (delete tag active-tags)))
1593 (toggle-action-active-p
1594 (action-group-get-action actions (text-tag-name tag)))
1597 ;; Callback to apply active tags when a character is inserted
1598 (signal-connect buffer 'insert-text
1599 #'(lambda (iter &rest args)
1600 (declare (ignore args))
1601 (let ((before (text-buffer-get-iter-at-offset buffer
1602 (1- (text-iter-offset iter)))))
1604 for tag in active-tags
1605 do (text-buffer-apply-tag buffer tag before iter))))
1608 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1609 (container-add dialog text-view)))))
1614 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1615 (make-instance 'v-box
1616 :border-width 10 :spacing 10 :parent dialog :show-all t
1619 collect (make-instance 'toggle-button
1620 :label (format nil "Button~D" (1+ n))))))
1626 ;; TODO: style properties
1627 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1628 (let ((toolbar (make-instance 'toolbar :parent window)))
1629 ; (setf (toolbar-relief toolbar) :none)
1631 ;; Insert a stock item
1632 (toolbar-append toolbar "gtk-quit"
1633 :tooltip-text "Destroy toolbar"
1634 :tooltip-private-text "Toolbar/Quit"
1635 :callback #'(lambda () (widget-destroy window)))
1637 ;; Image widge as icon
1638 (toolbar-append toolbar "Horizontal"
1639 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1640 :tooltip-text "Horizontal toolbar layout"
1641 :tooltip-private-text "Toolbar/Horizontal"
1642 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1645 (toolbar-append toolbar "Vertical"
1646 :icon #p"clg:examples;test.xpm"
1647 :tooltip-text "Vertical toolbar layout"
1648 :tooltip-private-text "Toolbar/Vertical"
1649 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1651 (toolbar-append toolbar :space)
1654 (toolbar-append toolbar "Icons"
1656 :tooltip-text "Only show toolbar icons"
1657 :tooltip-private-text "Toolbar/IconsOnly"
1658 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1660 ;; Icon from pixmap data
1661 (toolbar-append toolbar "Text"
1663 :tooltip-text "Only show toolbar text"
1664 :tooltip-private-text "Toolbar/TextOnly"
1665 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1667 (toolbar-append toolbar "Both"
1668 :tooltip-text "Show toolbar icons and text"
1669 :tooltip-private-text "Toolbar/Both"
1670 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1672 (toolbar-append toolbar :space)
1674 (toolbar-append toolbar (make-instance 'entry)
1675 :tooltip-text "This is an unusable GtkEntry"
1676 :tooltip-private-text "Hey don't click me!")
1678 (toolbar-append toolbar :space)
1680 ;; (toolbar-append-item
1681 ;; toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1682 ;; :tooltip-text "Use small spaces"
1683 ;; :tooltip-private-text "Toolbar/Small"
1684 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1686 ;; (toolbar-append-item
1687 ;; toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1688 ;; :tooltip-text "Use big spaces"
1689 ;; :tooltip-private-text "Toolbar/Big"
1690 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1692 ;; (toolbar-append toolbar :space)
1696 :tooltip-text "Enable tooltips"
1697 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1701 :tooltip-text "Disable tooltips"
1702 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1704 (toolbar-append toolbar :space)
1706 ;; (toolbar-append-item
1707 ;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1708 ;; :tooltip-text "Show borders"
1709 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1711 ;; (toolbar-append-item
1713 ;; "Borderless" (pixmap-new "clg:examples;test.xpm")
1714 ;; :tooltip-text "Hide borders"
1715 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1717 ;; (toolbar-append toolbar :space)
1719 ;; (toolbar-append-item
1720 ;; toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1721 ;; :tooltip-text "Empty spaces"
1722 ;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1724 ;; (toolbar-append-item
1725 ;; toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1726 ;; :tooltip-text "Lines in spaces"
1727 ;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1735 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1736 (let ((tooltips (make-instance 'tooltips)))
1737 (flet ((create-button (label tip-text tip-private)
1738 (let ((button (make-instance 'toggle-button :label label)))
1739 (tooltips-set-tip tooltips button tip-text tip-private)
1741 (make-instance 'v-box
1742 :parent dialog :border-width 10 :spacing 10 :show-all t
1743 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1744 :child (create-button "button2" "This is button 2. This is also 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")))))
1749 (defvar *ui-description*
1750 '((:menubar "MenuBar"
1755 (:menuitem "SaveAs")
1758 (:menu "PreferencesMenu"
1764 (:menuitem "Square")
1765 (:menuitem "Rectangle")
1769 (:menuitem "About")))
1774 (:toolitem "Logo"))))
1776 (define-toplevel create-ui-manager (window "UI Manager")
1778 (make-instance 'action-group
1780 :action (create-action "FileMenu" nil "_File")
1781 :action (create-action "PreferencesMenu" nil "_Preferences")
1782 :action (create-action "ColorMenu" nil "_Color")
1783 :action (create-action "ShapeMenu" nil "_Shape")
1784 :action (create-action "HelpMenu" nil "_Help")
1785 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1786 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
1787 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1788 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1789 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
1790 :action (create-action "About" nil "_About" "<control>A" "About")
1791 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1792 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1793 :actions (create-radio-actions
1794 '(("Red" nil "_Red" "<control>R" "Blood")
1795 ("Green" nil "_Green" "<control>G" "Grass")
1796 ("Blue" nil "_Blue" "<control>B" "Sky"))
1798 :actions (create-radio-actions
1799 '(("Square" nil "_Square" "<control>S" "Square")
1800 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1801 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1802 (ui (make-instance 'ui-manager)))
1804 (ui-manager-insert-action-group ui actions)
1805 (ui-manager-add-ui ui *ui-description*)
1807 (window-add-accel-group window (ui-manager-accel-group ui))
1809 (make-instance 'v-box
1810 :parent window :show-all t
1812 (ui-manager-get-widget ui "/MenuBar")
1813 :expand nil :fill nil)
1815 (ui-manager-get-widget ui "/ToolBar")
1816 :expand nil :fill nil)
1817 :child (make-instance 'label
1818 :label "Type <alt> to start"
1819 :xalign 0.5 :yalign 0.5
1820 :width-request 200 :height-request 200))))
1826 (defun create-main-window ()
1827 ;; (rc-parse "clg:examples;testgtkrc2")
1828 ;; (rc-parse "clg:examples;testgtkrc")
1830 (let* ((button-specs
1831 '(("button box" create-button-box)
1832 ("buttons" create-buttons)
1833 ("calendar" create-calendar)
1834 ("check buttons" create-check-buttons)
1835 ("color selection" create-color-selection)
1836 ("cursors" create-cursors)
1837 ("dialog" create-dialog)
1839 ("entry" create-entry)
1840 ;; ("event watcher")
1841 ("enxpander" create-expander)
1842 ("file chooser" create-file-chooser)
1843 ;; ("font selection")
1844 ;; ("handle box" create-handle-box)
1845 ("image" create-image)
1847 ("labels" create-labels)
1848 ("layout" create-layout)
1849 ("list" create-list)
1850 ("menus" create-menus)
1852 ("notebook" create-notebook)
1853 ("panes" create-panes)
1854 ;; ("progress bar" #|create-progress-bar|#)
1855 ("radio buttons" create-radio-buttons)
1856 ("range controls" create-range-controls)
1858 ("reparent" create-reparent)
1859 ("rulers" create-rulers)
1860 ;; ("saved position")
1861 ("scrolled windows" create-scrolled-windows)
1862 ("size group" create-size-group)
1863 ;; ("shapes" create-shapes)
1864 ("spinbutton" create-spins)
1865 ("statusbar" create-statusbar)
1866 ("test idle" create-idle-test)
1867 ;; ("test mainloop")
1868 ;; ("test scrolling")
1869 ;; ("test selection")
1870 ("test timeout" create-timeout-test)
1871 ("text" create-text)
1872 ("toggle buttons" create-toggle-buttons)
1873 ("toolbar" create-toolbar)
1874 ("tooltips" create-tooltips)
1875 ;; ("tree" #|create-tree|#)
1876 ("UI manager" create-ui-manager)
1878 (main-window (make-instance 'window
1879 :title "testgtk.lisp" :name "main_window"
1880 :default-width 200 :default-height 400
1881 :allow-grow t :allow-shrink nil))
1882 (scrolled-window (make-instance 'scrolled-window
1883 :hscrollbar-policy :automatic
1884 :vscrollbar-policy :automatic
1886 (close-button (make-instance 'button
1887 :label "close" :can-default t
1888 :signal (list 'clicked #'widget-destroy
1889 :object main-window))))
1892 (make-instance 'v-box
1894 :child-args '(:expand nil)
1895 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1896 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1897 :child (list scrolled-window :expand t)
1898 :child (make-instance 'h-separator)
1899 :child (make-instance 'v-box
1900 :homogeneous nil :spacing 10 :border-width 10
1901 :child close-button))
1904 (make-instance 'v-box
1905 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1906 :children (mapcar #'(lambda (spec)
1907 (apply #'create-button spec))
1909 (scrolled-window-add-with-viewport scrolled-window content-box))
1911 (widget-grab-focus close-button)
1912 (widget-show-all main-window)
1916 (create-main-window)