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.2 2000-10-05 18:57:50 espen Exp $
23 (defmacro define-test-window (name title &body body)
27 (setq window (window-new :toplevel))
29 window 'destroy #'(lambda () (widget-destroyed window)))
30 (setf (window-title window) ,title)
31 (setf (container-border-width window) 0)
34 (if (not (widget-visible-p window))
35 (widget-show-all window)
36 (widget-destroy window)))))
39 (defmacro define-test-dialog (name title &body body)
43 (setq window (make-instance 'dialog))
45 window 'destroy #'(lambda () (widget-destroyed window)))
46 (setf (window-title window) ,title)
47 (setf (container-border-width window) 0)
48 (let ((main-box (vbox-new nil 0))
49 (action-area (dialog-action-area window)))
50 (box-pack-start (dialog-main-box window) main-box t t 0)
53 (if (not (widget-visible-p window))
54 (widget-show-all window)
55 (widget-destroy window)))))
58 (defmacro define-standard-dialog (name title &body body)
59 `(define-test-dialog ,name ,title
60 (let ((close-button (button-new "close")))
61 (signal-connect close-button 'clicked #'widget-destroy :object window)
62 (setf (widget-can-default-p close-button) t)
63 (box-pack-start action-area close-button t t 0)
64 (widget-grab-default close-button)
69 ;;; Pixmaps used in some of the tests
111 (defvar book-closed-xpm
136 (defvar mini-page-xpm
159 (defvar book-open-xpm
186 (defun create-bbox-in-frame (class frame-label spacing width height layout)
187 (make-instance 'frame
189 :child (make-instance class
190 :border-width 5 :layout layout :spacing spacing
191 :child-min-width width :child-min-height height
195 (button-new "Cancel")
196 (button-new "Help")))))
198 (define-test-window create-button-box "Button Boxes"
199 (setf (container-border-width window) 10)
205 (make-instance 'frame
206 :label "Horizontal Button Boxes"
213 (list (apply #'create-bbox-in-frame 'hbutton-box args) :padding 5))
214 '(("Spread" 40 85 20 :spread) ("Edge" 40 85 20 :edge)
215 ("Start" 40 85 20 :start) ("End" 40 85 20 :end)))))
219 (make-instance 'frame
220 :label "Vertical Button Boxes"
227 (list (apply #'create-bbox-in-frame 'vbutton-box args) :padding 5))
228 '(("Spread" 30 85 20 :spread) ("Edge" 30 85 20 :edge)
229 ("Start" 30 85 20 :start) ("End" 30 85 20 :end)))))
235 (define-standard-dialog create-buttons "Buttons"
236 (let ((table (make-instance 'table
237 :rows 3 :columns 3 :homogeneous nil
238 :row-spacing 5 :column-spacing 5 :border-width 10
240 (buttons (make-array 0 :adjustable t :fill-pointer t)))
243 (button-new (format nil "button~D" (1+ n))) buttons))
246 (let ((button (aref buttons (+ (* 3 row) column)))
247 (button+1 (aref buttons (mod (+ (* 3 row) column 1) 9))))
248 (signal-connect button 'clicked
250 (if (widget-visible-p button+1)
251 (widget-hide button+1)
252 (widget-show button+1))))
253 (table-attach table button column (1+ column) row (1+ row)))))))
258 (define-standard-dialog create-calendar "Calendar"
259 (setf (container-border-width main-box) 10)
260 (make-instance 'calendar :parent main-box))
265 (define-standard-dialog create-check-buttons "Check Buttons"
266 (setf (container-border-width main-box) 10)
267 (setf (box-spacing main-box) 10)
269 (make-instance 'check-button
270 :label (format nil "Button~D" (1+ n))
277 (let ((color-dialog nil))
278 (defun create-color-selection ()
282 (make-instance 'color-selection-dialog
283 :title "Color selection dialog" :position :mouse
284 :allow-grow nil :allow-shrink nil
286 (list (list 'destroy #'(lambda () (widget-destroyed color-dialog))))))
288 (with-slots (main-box colorsel) color-dialog
289 (make-instance 'hbutton-box
290 :border-width 10 :layout :edge :visible t
294 "Show Opacity" '(setf color-selection-use-opacity-p) nil colorsel)
296 "Show Palette" '(setf color-selection-use-palette-p) nil colorsel))
300 (color-selection-dialog-ok-button color-dialog) 'clicked
302 (let ((color (color-selection-color colorsel)))
303 (format t "Selected color: ~A~%" color)
304 (setf (color-selection-color colorsel) color))))
306 (color-selection-dialog-cancel-button color-dialog) 'clicked
307 #'widget-destroy :object color-dialog)))
309 (if (not (widget-visible-p color-dialog))
310 (widget-show color-dialog)
311 (widget-destroy color-dialog))))
318 (defun clamp (n min-val max-val)
319 (declare (number n min-val max-val))
320 (max (min n max-val) min-val))
323 ; (defun set-cursor (spinner drawing-area label)
326 ; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
327 ; 'gdk:cursor-type)))
328 ; (setf (label-text label) (string-downcase (symbol-name cursor)))
329 ; (setf (widget-cursor drawing-area) cursor)))
332 ; (define-standard-dialog create-cursors "Cursors"
333 ; (setf (container-border-width main-box) 10)
334 ; (setf (box-spacing main-box) 5)
335 ; (let* ((hbox (hbox-new nil 0))
336 ; (label (label-new "Cursor Value : "))
337 ; (adj (adjustment-new 0 0 152 2 10 0))
338 ; (spinner (spin-button-new adj 0 0)))
339 ; (setf (container-border-width hbox) 5)
340 ; (box-pack-start main-box hbox nil t 0)
341 ; (setf (misc-xalign label) 0)
342 ; (setf (misc-yalign label) 0.5)
343 ; (box-pack-start hbox label nil t 0)
344 ; (box-pack-start hbox spinner t t 0)
346 ; (let ((frame (make-frame
347 ; :shadow-type :etched-in
349 ; :label "Cursor Area"
353 ; (drawing-area (drawing-area-new)))
354 ; (setf (widget-width drawing-area) 80)
355 ; (setf (widget-height drawing-area) 80)
356 ; (container-add frame drawing-area)
358 ; drawing-area 'expose-event
360 ; (declare (ignore event))
361 ; (multiple-value-bind (width height)
362 ; (drawing-area-size drawing-area)
363 ; (let* ((drawable (widget-window drawing-area))
364 ; (style (widget-style drawing-area))
365 ; (white-gc (style-get-gc style :white))
366 ; (gray-gc (style-get-gc style :background :normal))
367 ; (black-gc (style-get-gc style :black)))
368 ; (gdk:draw-rectangle
369 ; drawable white-gc t 0 0 width (floor height 2))
370 ; (gdk:draw-rectangle
371 ; drawable black-gc t 0 (floor height 2) width (floor height 2))
372 ; (gdk:draw-rectangle
373 ; drawable gray-gc t (floor width 3) (floor height 3)
374 ; (floor width 3) (floor height 3))))
376 ; (setf (widget-events drawing-area) '(:exposure :button-press))
378 ; drawing-area 'button-press-event
381 ; (eq (gdk:event-type event) :button-press)
383 ; (= (gdk:event-button event) 1)
384 ; (= (gdk:event-button event) 3)))
387 ; (if (= (gdk:event-button event) 1)
392 ; (widget-show drawing-area)
394 ; (let ((label (make-label
397 ; :parent main-box)))
398 ; (setf (box-child-expand-p #|main-box|# label) nil)
402 ; (set-cursor spinner drawing-area label)))
404 ; (widget-realize drawing-area)
405 ; (set-cursor spinner drawing-area label)))))
411 (define-test-dialog create-dialog "Dialog"
412 (setf (widget-width window) 200)
413 (setf (widget-height window) 110)
415 (let ((button (button-new "OK")))
416 (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
417 (setf (widget-can-default-p button) t)
418 (box-pack-start action-area button t t 0)
419 (widget-grab-default button)
420 (widget-show button))
422 (let ((button (button-new "Toggle"))
429 (setq label (label-new "Dialog Test"))
430 (signal-connect label 'destroy #'widget-destroy :object label)
431 (setf (misc-xpad label) 10)
432 (setf (misc-ypad label) 10)
433 (box-pack-start main-box label t t 0)
436 (widget-destroy label)
438 (setf (widget-can-default-p button) t)
439 (box-pack-start action-area button t t 0)
440 (widget-grab-default button)
441 (widget-show button)))
447 (define-standard-dialog create-entry "Entry"
448 (setf (container-border-width main-box) 10)
449 (setf (box-spacing main-box) 10)
450 (let ((entry (make-instance 'entry :text "hello world" :parent main-box)))
451 (editable-select-region entry 0 5)
453 (let ((combo (make-instance 'combo :parent main-box)))
455 (combo-popdown-strings combo)
459 "item3 item3 item3 item3"
460 "item4 item4 item4 item4 item4"
461 "item5 item5 item5 item5 item5 item5"
462 "item6 item6 item6 item6 item6"
463 "item7 item7 item7 item7"
466 (let ((entry (combo-entry combo)))
467 (setf (editable-text entry) "hello world")
468 (editable-select-region entry 0)))
470 (flet ((create-check-button (label slot)
472 (make-instance 'check-button
473 :label label :active t
474 :parent (list main-box :expand nil))))
475 (signal-connect button 'toggled
478 (slot-value entry slot)
479 (toggle-button-active-p button)))))))
481 (create-check-button "Editable" 'editable)
482 (create-check-button "Visible" 'visible)
483 (create-check-button "Sensitive" 'sensitive))))
487 ;; File selecetion dialog
490 (defun create-file-selection ()
492 (setq filesel (file-selection-new "file selection dialog"))
493 (file-selection-hide-fileop-buttons filesel)
494 (setf (window-position filesel) :mouse)
496 filesel 'destroy #'(lambda () (widget-destroyed filesel)))
498 (file-selection-ok-button filesel) 'clicked
501 t "Selected file: ~A~%" (file-selection-filename filesel))
502 (widget-destroy filesel)))
504 (file-selection-cancel-button filesel) 'clicked
505 #'widget-destroy :object filesel)
507 (let ((button (button-new "Hide Fileops")))
510 #'file-selection-hide-fileop-buttons :object filesel)
511 (box-pack-start (file-selection-action-area filesel) button nil nil 0)
512 (widget-show button))
514 (let ((button (button-new "Show Fileops")))
517 #'file-selection-show-fileop-buttons :object filesel)
518 (box-pack-start (file-selection-action-area filesel) button nil nil 0)
519 (widget-show button)))
521 (if (not (widget-visible-p filesel))
522 (widget-show-all filesel)
523 (widget-destroy filesel))))
529 (defun create-handle-box-toolbar ()
530 (let ((toolbar (toolbar-new :horizontal :both)))
532 toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
533 :tooltip-text "Horizontal toolbar layout"
534 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
537 toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
538 :tooltip-text "Vertical toolbar layout"
539 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
541 (toolbar-append-space toolbar)
544 toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
545 :tooltip-text "Only show toolbar icons"
546 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
549 toolbar "Text" (pixmap-new "clg:examples;test.xpm")
550 :tooltip-text "Only show toolbar text"
551 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
554 toolbar "Both" (pixmap-new "clg:examples;test.xpm")
555 :tooltip-text "Show toolbar icons and text"
556 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
558 (toolbar-append-space toolbar)
561 toolbar "Small" (pixmap-new "clg:examples;test.xpm")
562 :tooltip-text "Use small spaces"
563 :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
566 toolbar "Big" (pixmap-new "clg:examples;test.xpm")
567 :tooltip-text "Use big spaces"
568 :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
570 (toolbar-append-space toolbar)
573 toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
574 :tooltip-text "Enable tooltips"
575 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
578 toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
579 :tooltip-text "Disable tooltips"
580 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
582 (toolbar-append-space toolbar)
585 toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
586 :tooltip-text "Show borders"
587 :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
590 toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
591 :tooltip-text "Hide borders"
592 :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
597 (defun handle-box-child-signal (handle-box child action)
598 (format t "~S: child ~S ~A~%" handle-box child action))
601 (define-test-window create-handle-box "Handle Box Test"
602 (setf (window-allow-grow-p window) t)
603 (setf (window-allow-shrink-p window) t)
604 (setf (window-auto-shrink-p window) nil)
605 (setf (container-border-width window) 20)
606 (let ((vbox (vbox-new nil 0)))
607 (container-add window vbox)
609 (container-add vbox (label-new "Above"))
610 (container-add vbox (hseparator-new))
612 (let ((hbox (hbox-new nil 10)))
613 (container-add vbox hbox)
615 (let ((handle-box (handle-box-new)))
616 (box-pack-start hbox handle-box nil nil 0)
618 handle-box 'child-attached
620 (handle-box-child-signal handle-box child "attached")))
622 handle-box 'child-detached
624 (handle-box-child-signal handle-box child "detached")))
625 (container-add handle-box (create-handle-box-toolbar)))
627 (let ((handle-box (handle-box-new)))
628 (box-pack-start hbox handle-box nil nil 0)
630 handle-box 'child-attached
632 (handle-box-child-signal handle-box child "attached")))
634 handle-box 'child-detached
636 (handle-box-child-signal handle-box child "detached")))
638 (let ((handle-box2 (handle-box-new)))
639 (container-add handle-box handle-box2)
641 handle-box2 'child-attached
643 (handle-box-child-signal handle-box child "attached")))
645 handle-box2 'child-detached
647 (handle-box-child-signal handle-box child "detached")))
648 (container-add handle-box2 (label-new "Foo!")))))
650 (container-add vbox (hseparator-new))
651 (container-add vbox (label-new "Below"))))
657 (define-test-window create-labels "Labels"
658 (setf (container-border-width window) 5)
659 (flet ((create-label-in-frame (frame-label label-text &rest args)
661 (make-instance 'frame
664 (apply #'make-instance 'label :label label-text args))
665 :fill nil :expand nil)))
676 (create-label-in-frame "Normal Label" "This is a Normal label")
677 (create-label-in-frame "Multi-line Label"
678 "This is a Multi-line label.
681 (create-label-in-frame "Left Justified Label"
682 "This is a Left-Justified
686 (create-label-in-frame "Right Justified Label"
687 "This is a Right-Justified
691 :fill nil :expand nil)
698 (create-label-in-frame "Line wrapped label"
699 "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.
700 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
702 (create-label-in-frame "Filled, wrapped label"
703 "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.
704 This is a new paragraph.
705 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
706 :justify :fill :wrap t)
707 (create-label-in-frame "Underlined label"
708 "This label is underlined!
709 This one is underlined (こんにちは) in quite a funky fashion"
711 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))
712 :fill nil :expand nil)))))
718 (defun layout-expose-handler (layout event)
719 (with-slots (window x-offset y-offset) layout
720 (with-slots (x y width height) event
721 (let ((imin (truncate (+ x-offset x) 10))
722 (imax (truncate (+ x-offset x width 9) 10))
723 (jmin (truncate (+ y-offset y) 10))
724 (jmax (truncate (+ y-offset y height 9) 10)))
725 (declare (fixnum imin imax jmin jmax))
726 (gdk:window-clear-area window x y width height)
728 (let ((window (layout-bin-window layout))
729 (gc (style-get-gc (widget-style layout) :black)))
730 (do ((i imin (1+ i)))
733 (do ((j jmin (1+ j)))
736 (unless (zerop (mod (+ i j) 2))
739 (- (* 10 i) x-offset) (- (* 10 j) y-offset)
740 (1+ (mod i 10)) (1+ (mod j 10))))))))))
744 (define-test-window create-layout "Layout"
745 (setf (widget-width window) 200)
746 (setf (widget-height window) 200)
747 (let ((layout (make-instance 'layout
748 :parent (make-instance 'scrolled-window :parent window)
749 :x-size 1600 :y-size 128000
750 :events '(:exposure))))
752 (with-slots (hadjustment vadjustment) layout
754 (adjustment-step-increment hadjustment) 10.0
755 (adjustment-step-increment vadjustment) 10.0))
756 (signal-connect layout 'expose-event #'layout-expose-handler :object t)
760 (let* ((text (format nil "Button ~D, ~D" i j))
761 (button (if (not (zerop (mod (+ i j) 2)))
764 (layout-put layout button (* j 100) (* i 100)))))
769 (let* ((text (format nil "Button ~D, ~D" i 0))
770 (button (if (not (zerop (mod i 2)))
773 (layout-put layout button 0 (* i 100))))))
779 (define-standard-dialog create-list "List"
780 (let ((scrolled-window (scrolled-window-new))
782 (setf (container-border-width scrolled-window) 5)
783 (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
784 (box-pack-start main-box scrolled-window t t 0)
785 (setf (widget-height scrolled-window) 300)
787 (setf (list-selection-mode list) :extended)
788 (scrolled-window-add-with-viewport scrolled-window list)
790 (container-focus-vadjustment list)
791 (scrolled-window-vadjustment scrolled-window))
793 (container-focus-hadjustment list)
794 (scrolled-window-hadjustment scrolled-window))
796 (with-open-file (file "clg:examples;gtktypes.lisp")
797 (labels ((read-file ()
798 (let ((line (read-line file nil nil)))
800 (container-add list (list-item-new line))
804 (let ((hbox (hbox-new t 5)))
805 (setf (container-border-width hbox) 5)
806 (box-pack-start main-box hbox nil t 0)
808 (let ((button (button-new "Insert Row"))
810 (box-pack-start hbox button t t 0)
815 (list-item-new (format nil "added item ~A" (incf i)))))
817 (container-add list item)))))
819 (let ((button (button-new "Clear List")))
820 (box-pack-start hbox button t t 0)
822 button 'clicked #'(lambda () (list-clear-items list 0 -1))))
824 (let ((button (button-new "Remove Selection")))
825 (box-pack-start hbox button t t 0)
829 (let ((selection (list-selection list)))
830 (if (eq (list-selection-mode list) :extended)
832 (container-focus-child list)
835 (let* ((children (container-children list))
840 (eq (widget-state item) :selected))
841 (member item children))
844 (eq (widget-state item) :selected))
845 (member item (reverse children))))))
846 (list-remove-items list selection)
848 (list-select-child list sel-row)))))
849 (list-remove-items list selection)))))
850 (box-pack-start hbox button t t 0)))
852 (let ((cbox (hbox-new nil 0)))
853 (box-pack-start main-box cbox nil t 0)
855 (let ((hbox (hbox-new nil 5))
859 ,#'(lambda () (setf (list-selection-mode list) :single)))
861 ,#'(lambda () (setf (list-selection-mode list) :browse)))
863 ,#'(lambda () (setf (list-selection-mode list) :multiple)))
865 ,#'(lambda () (setf (list-selection-mode list) :extended))))
868 (setf (container-border-width hbox) 5)
869 (box-pack-start cbox hbox t nil 0)
870 (box-pack-start hbox (label-new "Selection Mode :") nil t 0)
871 (box-pack-start hbox option-menu nil t 0)))))
877 (defun create-menu (depth tearoff)
878 (unless (zerop depth)
879 (let ((menu (menu-new)))
881 (let ((menuitem (tearoff-menu-item-new)))
882 (menu-shell-append menu menuitem)
883 (widget-show menuitem)
889 (format nil "item ~2D - ~D" depth (1+ i)) group)))
890 (setq group menuitem)
891 (unless (zerop (mod depth 2))
892 (setf (check-menu-item-toggle-indicator-p menuitem) t))
893 (menu-shell-append menu menuitem)
894 (widget-show menuitem)
896 (setf (widget-sensitive-p menuitem) nil))
897 (setf (menu-item-submenu menuitem) (create-menu (1- depth) t)))))
901 (define-standard-dialog create-menus "Menus"
902 (setf (box-spacing main-box) 0)
903 (setf (container-border-width main-box) 0)
904 (widget-show main-box)
905 (let ((accel-group (accel-group-new))
906 (menubar (menu-bar-new)))
907 (accel-group-attach accel-group window)
908 (box-pack-start main-box menubar nil t 0)
909 (widget-show menubar)
911 (let ((menuitem (menu-item-new (format nil "test~%line2"))))
912 (setf (menu-item-submenu menuitem) (create-menu 2 t))
913 (menu-shell-append menubar menuitem)
914 (widget-show menuitem))
916 (let ((menuitem (menu-item-new "foo")))
917 (setf (menu-item-submenu menuitem) (create-menu 3 t))
918 (menu-shell-append menubar menuitem)
919 (widget-show menuitem))
921 (let ((menuitem (menu-item-new "bar")))
922 (setf (menu-item-submenu menuitem) (create-menu 4 t))
923 (menu-item-right-justify menuitem)
924 (menu-shell-append menubar menuitem)
925 (widget-show menuitem))
927 (let ((box2 (vbox-new nil 10))
928 (menu (create-menu 1 nil)))
929 (setf (container-border-width box2) 10)
930 (box-pack-start main-box box2 t t 0)
933 (setf (menu-accel-group menu) accel-group)
935 (let ((menuitem (check-menu-item-new "Accelerate Me")))
936 (menu-shell-append menu menuitem)
937 (widget-show menuitem)
938 (widget-add-accelerator
939 menuitem 'activate accel-group "F1" '() '(:visible :signal-visible)))
941 (let ((menuitem (check-menu-item-new "Accelerator Locked")))
942 (menu-shell-append menu menuitem)
943 (widget-show menuitem)
944 (widget-add-accelerator
945 menuitem 'activate accel-group "F2" '() '(:visible :locked)))
947 (let ((menuitem (check-menu-item-new "Accelerator Frozen")))
948 (menu-shell-append menu menuitem)
949 (widget-show menuitem)
950 (widget-add-accelerator
951 menuitem 'activate accel-group "F2" '() '(:visible))
952 (widget-add-accelerator
953 menuitem 'activate accel-group "F3" '() '(:visible))
954 (widget-lock-accelerators menuitem))
956 (let ((optionmenu (option-menu-new)))
957 (setf (option-menu-menu optionmenu) menu)
958 (setf (option-menu-history optionmenu) 3)
959 (box-pack-start box2 optionmenu t t 0)
960 (widget-show optionmenu)))))
965 (define-standard-dialog create-notebook "Notebook"
966 (multiple-value-bind (book-open book-open-mask)
967 (gdk:pixmap-create book-open-xpm)
968 (multiple-value-bind (book-closed book-closed-mask)
969 (gdk:pixmap-create book-closed-xpm)
972 ((create-pages (notebook i end)
974 (let* ((title (format nil "Page ~D" i))
975 (child (frame-new title))
976 (vbox (vbox-new t 0))
977 (hbox (hbox-new t 0)))
978 (setf (container-border-width child) 10)
979 (setf (container-border-width vbox) 10)
980 (container-add child vbox)
981 (box-pack-start vbox hbox nil t 5)
983 (let ((button (check-button-new "Fill Tab")))
984 (box-pack-start hbox button t t 5)
985 (setf (toggle-button-active-p button) t)
989 (multiple-value-bind (expand fill pack-type)
990 (notebook-query-tab-label-packing notebook child)
991 (declare (ignore fill))
992 (notebook-set-tab-label-packing
993 notebook child expand
994 (toggle-button-active-p button) pack-type)))))
996 (let ((button (check-button-new "Expand Tab")))
997 (box-pack-start hbox button t t 5)
1001 (multiple-value-bind (expand fill pack-type)
1002 (notebook-query-tab-label-packing notebook child)
1003 (declare (ignore expand))
1004 (notebook-set-tab-label-packing
1005 notebook child (toggle-button-active-p button)
1008 (let ((button (check-button-new "Pack end")))
1009 (box-pack-start hbox button t t 5)
1013 (multiple-value-bind (expand fill pack-type)
1014 (notebook-query-tab-label-packing notebook child)
1015 (declare (ignore pack-type))
1016 (notebook-set-tab-label-packing
1017 notebook child expand fill
1018 (if (toggle-button-active-p button)
1022 (let ((button (button-new "Hide Page")))
1023 (box-pack-start vbox button nil nil 5)
1025 button 'clicked #'(lambda () (widget-hide child))))
1027 (widget-show-all child)
1029 (let ((label-box (hbox-new nil 0))
1030 (menu-box (hbox-new nil 0)))
1032 label-box (pixmap-new book-closed book-closed-mask)
1034 (box-pack-start label-box (label-new title) nil t 0)
1035 (widget-show-all label-box)
1037 menu-box (pixmap-new book-closed book-closed-mask)
1039 (box-pack-start menu-box (label-new title) nil t 0)
1040 (widget-show-all menu-box)
1041 (notebook-append-page notebook child label-box menu-box)))
1043 (create-pages notebook (1+ i) end))))
1046 (setf (container-border-width main-box) 0)
1047 (setf (box-spacing main-box) 0)
1049 (let ((notebook (notebook-new)))
1051 notebook 'switch-page
1052 #'(lambda (pointer page)
1053 (declare (ignore pointer))
1054 (let ((old-page (notebook-page-child notebook)))
1055 (unless (eq page old-page)
1059 (notebook-tab-label notebook page)))
1060 book-open book-open-mask)
1064 (notebook-menu-label notebook page)))
1065 book-open book-open-mask)
1071 (notebook-tab-label notebook old-page)))
1072 book-closed book-closed-mask)
1076 (notebook-menu-label notebook old-page)))
1077 book-closed book-closed-mask))
1080 (setf (notebook-tab-pos notebook) :top)
1081 (box-pack-start main-box notebook t t 0)
1082 (setf (container-border-width notebook) 10)
1084 (widget-realize notebook)
1085 (create-pages notebook 1 5)
1087 (box-pack-start main-box (hseparator-new) nil t 10)
1089 (let ((box2 (hbox-new nil 5)))
1090 (setf (container-border-width box2) 10)
1091 (box-pack-start main-box box2 nil t 0)
1093 (let ((button (check-button-new "popup menu")))
1094 (box-pack-start box2 button t nil 0)
1098 (if (toggle-button-active-p button)
1099 (notebook-popup-enable notebook)
1100 (notebook-popup-disable notebook)))))
1102 (let ((button (check-button-new "homogeneous tabs")))
1103 (box-pack-start box2 button t nil 0)
1108 (notebook-homogeneous-p notebook)
1109 (toggle-button-active-p button))))))
1111 (let ((box2 (hbox-new nil 5)))
1112 (setf (container-border-width box2) 10)
1113 (box-pack-start main-box box2 nil t 0)
1115 (box-pack-start box2 (label-new "Notebook Style : ") nil t 0)
1117 (let* ((scrollable-p nil)
1122 (setf (notebook-show-tabs-p notebook) t)
1124 (setq scrollable-p nil)
1125 (setf (notebook-scrollable-p notebook) nil)
1127 (notebook-remove-page notebook 5)))))
1130 (setf (notebook-show-tabs-p notebook) nil)
1132 (setq scrollable-p nil)
1133 (setf (notebook-scrollable-p notebook) nil)
1135 (notebook-remove-page notebook 5)))))
1138 (unless scrollable-p
1139 (setq scrollable-p t)
1140 (setf (notebook-show-tabs-p notebook) t)
1141 (setf (notebook-scrollable-p notebook) t)
1142 (create-pages notebook 6 15)))))
1144 (box-pack-start box2 option-menu nil t 0))
1146 (let ((button (button-new "Show all Pages")))
1147 (box-pack-start box2 button nil t 0)
1151 (map-container nil #'widget-show notebook)))))
1153 (let ((box2 (hbox-new nil 5)))
1154 (setf (container-border-width box2) 10)
1155 (box-pack-start main-box box2 nil t 0)
1157 (let ((button (button-new "prev")))
1158 (box-pack-start box2 button t t 0)
1162 (notebook-prev-page notebook))))
1164 (let ((button (button-new "next")))
1165 (box-pack-start box2 button t t 0)
1169 (notebook-next-page notebook))))
1171 (let ((button (button-new "rotate"))
1173 (box-pack-start box2 button t t 0)
1177 (setq tab-pos (mod (1+ tab-pos) 4))
1179 (notebook-tab-pos notebook)
1180 (svref #(:top :bottom :right :left) tab-pos)))))))))))
1186 (defun toggle-resize (child)
1187 (let* ((paned (widget-parent child))
1188 (is-child1-p (eq child (paned-child1 paned))))
1189 (multiple-value-bind (child resize shrink)
1191 (paned-child1 paned)
1192 (paned-child2 paned))
1193 (container-remove paned child)
1195 (paned-pack1 paned child (not resize) shrink)
1196 (paned-pack2 paned child (not resize) shrink)))))
1198 (defun toggle-shrink (child)
1199 (let* ((paned (widget-parent child))
1200 (is-child1-p (eq child (paned-child1 paned))))
1201 (multiple-value-bind (child resize shrink)
1203 (paned-child1 paned)
1204 (paned-child2 paned))
1205 (container-remove paned child)
1207 (paned-pack1 paned child resize (not shrink))
1208 (paned-pack2 paned child resize (not shrink))))))
1210 (defun create-pane-options (paned frame-label label1 label2)
1211 (let* ((frame (make-instance 'frame
1212 :label frame-label :border-width 4))
1213 (table (make-instance 'table
1214 :rows 3 :columns 2 :homogeneous t :parent frame)))
1216 (table-attach table (label-new label1) 0 1 0 1)
1217 (let ((check-button (check-button-new "Resize")))
1218 (table-attach table check-button 0 1 1 2)
1220 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1221 (let ((check-button (check-button-new "Shrink")))
1222 (table-attach table check-button 0 1 2 3)
1223 (setf (toggle-button-active-p check-button) t)
1225 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1227 (table-attach table (label-new label2) 1 2 0 1)
1228 (let ((check-button (check-button-new "Resize")))
1229 (table-attach table check-button 1 2 1 2)
1230 (setf (toggle-button-active-p check-button) t)
1232 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1233 (let ((check-button (check-button-new "Shrink")))
1234 (table-attach table check-button 1 2 2 3)
1235 (setf (toggle-button-active-p check-button) t)
1237 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1241 (define-test-window create-panes "Panes"
1242 (let* ((hpaned (make-instance 'hpaned
1243 :child1 (make-instance 'frame
1244 :shadow-type :in :width 60 :height 60
1245 :child (button-new "Hi there"))
1246 :child2 (make-instance 'frame
1247 :shadow-type :in :width 80 :height 60)))
1248 (vpaned (make-instance 'vpaned
1251 :child2 (make-instance 'frame
1252 :shadow-type :in :width 80 :height 60))))
1254 (make-instance 'vbox
1260 (create-pane-options hpaned "Horizontal" "Left" "Right") :expand nil)
1262 (create-pane-options vpaned "Vertical" "Top" "Bottom") :expand nil)))))
1268 (define-standard-dialog create-pixmap "Pixmap"
1269 (setf (container-border-width main-box) 10)
1270 (make-instance 'button
1272 :child (make-instance 'hbox
1276 (pixmap-new "clg:examples;test.xpm")
1277 (label-new "Pixmap test")))))
1288 (define-standard-dialog create-radio-buttons "Radio buttons"
1289 (setf (container-border-width main-box) 10)
1290 (setf (box-spacing main-box) 10)
1294 (box-pack-start main-box button t t 0))
1295 (create-radio-button-group '("button1" "button2" "button3") 1)))
1300 (define-standard-dialog create-range-controls "Range controls"
1301 (setf (container-border-width main-box) 10)
1302 (setf (box-spacing main-box) 10)
1303 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1304 (make-instance 'hscale
1305 :width 150 :height 30 :adjustment adjustment
1306 :update-policy :delayed :digits 1 :draw-value t :parent main-box)
1307 (make-instance 'hscrollbar
1308 :adjustment adjustment :update-policy :continuous :parent main-box)))
1314 (define-standard-dialog create-reparent "reparent"
1315 (let ((box2 (hbox-new nil 5))
1316 (label (label-new "Hellow World")))
1317 (setf (container-border-width box2) 10)
1318 (box-pack-start main-box box2 t t 0)
1320 (let ((frame (frame-new "Frame 1"))
1321 (box3 (vbox-new nil 5))
1322 (button (button-new "switch")))
1323 (box-pack-start box2 frame t t 0)
1325 (setf (container-border-width box3) 5)
1326 (container-add frame box3)
1331 (widget-reparent label box3)))
1332 (box-pack-start box3 button nil t 0)
1334 (box-pack-start box3 label nil t 0)
1337 #'(lambda (old-parent)
1338 (declare (ignore old-parent)))))
1340 (let ((frame (frame-new "Frame 2"))
1341 (box3 (vbox-new nil 5))
1342 (button (button-new "switch")))
1343 (box-pack-start box2 frame t t 0)
1345 (setf (container-border-width box3) 5)
1346 (container-add frame box3)
1351 (widget-reparent label box3)))
1352 (box-pack-start box3 button nil t 0))))
1358 (define-test-window create-rulers "rulers"
1359 (setf (widget-width window) 300)
1360 (setf (widget-height window) 300)
1361 (setf (widget-events window) '(:pointer-motion :pointer-motion-hint))
1363 (let ((table (make-instance 'table
1367 (let ((ruler (make-instance 'hruler
1368 :metric :centimeters
1369 :lower 100.0 :upper 0.0
1370 :position 0.0 :max-size 20.0)))
1372 window 'motion-notify-event
1373 #'(lambda (event) (widget-event ruler event)))
1374 (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
1376 (let ((ruler (make-instance 'vruler
1377 :lower 5.0 :upper 15.0
1378 :position 0.0 :max-size 20.0)))
1380 window 'motion-notify-event
1381 #'(lambda (event) (widget-event ruler event)))
1382 (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
1388 (define-standard-dialog create-scrolled-windows "Scrolled windows"
1389 (let* ((scrolled-window
1390 (make-instance 'scrolled-window
1393 :vscrollbar-policy :automatic
1394 :hscrollbar-policy :automatic))
1396 (make-instance 'table
1397 :rows 20 :columns 20 :row-spacing 10 :column-spacing 10
1398 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1399 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1401 (scrolled-window-add-with-viewport scrolled-window table)
1405 (toggle-button-new (format nil "button (~D,~D)~%" i j))))
1406 (table-attach table button i (1+ i) j (1+ j))))))
1408 ; (let ((button (button-new "remove")))
1409 ; (signal-connect button 'clicked #'(lambda ()))
1410 ; (setf (widget-can-default-p button) t)
1411 ; (box-pack-start action-area button t t 0)
1412 ; (widget-grab-default button))
1414 (setf (window-default-height window) 300)
1415 (setf (window-default-width window) 300))
1421 (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1423 (make-instance 'window
1424 :type type :x x :y y
1425 :events '(:button-motion :pointer-motion-hint :button-press)))
1427 (make-instance 'fixed
1428 :parent window :width 100 :height 100)))
1430 (widget-realize window)
1431 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1432 (let ((pixmap (pixmap-new source mask))
1435 (declare (fixnum x-offset y-offset))
1436 (fixed-put fixed pixmap px py)
1437 (widget-shape-combine-mask window mask px py)
1439 (signal-connect window 'button-press-event
1441 (when (typep event 'gdk:button-press-event)
1442 (setq x-offset (truncate (gdk:event-x event)))
1443 (setq y-offset (truncate (gdk:event-y event)))
1446 (widget-window window) t
1447 '(:button-release :button-motion :pointer-motion-hint)
1451 (signal-connect window 'button-release-event
1453 (declare (ignore event))
1454 (grab-remove window)
1455 (gdk:pointer-ungrab 0)
1458 (signal-connect window 'motion-notify-event
1460 (declare (ignore event))
1461 (multiple-value-bind (win xp yp mask)
1462 (gdk:window-get-pointer root-window)
1463 (declare (ignore mask win) (fixnum xp yp))
1464 (widget-set-uposition
1465 window :x (- xp x-offset) :y (- yp y-offset)))
1467 (signal-connect window 'destroy destroy)))
1469 (widget-show-all window)
1473 (let ((modeller nil)
1476 (defun create-shapes ()
1477 (let ((root-window (gdk:get-root-window)))
1482 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1483 #'(lambda () (widget-destroyed modeller))))
1484 (widget-destroy modeller))
1490 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1491 #'(lambda () (widget-destroyed sheets))))
1492 (widget-destroy sheets))
1498 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1499 #'(lambda () (widget-destroyed rings))))
1500 (widget-destroy rings)))))
1506 (define-test-window create-spins "Spin buttons"
1507 (let ((main-vbox (vbox-new nil 5)))
1508 (setf (container-border-width main-vbox) 10)
1509 (container-add window main-vbox)
1511 (let ((frame (frame-new "Not accelerated"))
1512 (vbox (vbox-new nil 0))
1513 (hbox (hbox-new nil 0)))
1514 (box-pack-start main-vbox frame t t 0)
1515 (setf (container-border-width vbox) 5)
1516 (container-add frame vbox)
1517 (box-pack-start vbox hbox t t 5)
1519 (let* ((vbox2 (vbox-new nil 0))
1520 (label (label-new "Day :"))
1521 (spinner (spin-button-new
1522 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) 0.0 0)))
1523 (box-pack-start hbox vbox2 t t 5)
1524 (setf (misc-xalign label) 0.0)
1525 (setf (misc-yalign label) 0.5)
1526 (box-pack-start vbox2 label nil t 0)
1527 (setf (spin-button-wrap-p spinner) t)
1528 (setf (spin-button-shadow-type spinner) :out)
1529 (box-pack-start vbox2 spinner nil t 0))
1531 (let* ((vbox2 (vbox-new nil 0))
1532 (label (label-new "Month :"))
1533 (spinner (spin-button-new
1534 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) 0.0 0)))
1535 (box-pack-start hbox vbox2 t t 5)
1536 (setf (misc-xalign label) 0.0)
1537 (setf (misc-yalign label) 0.5)
1538 (box-pack-start vbox2 label nil t 0)
1539 (setf (spin-button-wrap-p spinner) t)
1540 (setf (spin-button-shadow-type spinner) :etched-in)
1541 (box-pack-start vbox2 spinner nil t 0))
1543 (let* ((vbox2 (vbox-new nil 0))
1544 (label (label-new "Year :"))
1545 (spinner (spin-button-new
1546 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0)
1548 (box-pack-start hbox vbox2 t t 5)
1549 (setf (misc-xalign label) 0.0)
1550 (setf (misc-yalign label) 0.5)
1551 (box-pack-start vbox2 label nil t 0)
1552 (setf (spin-button-wrap-p spinner) t)
1553 (setf (spin-button-shadow-type spinner) :in)
1554 (box-pack-start vbox2 spinner nil t 0)))
1556 (let* ((frame (frame-new "Accelerated"))
1557 (vbox (vbox-new nil 0))
1558 (hbox (hbox-new nil 0))
1559 (spinner1 (spin-button-new
1560 (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1562 (adj (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0))
1563 (spinner2 (spin-button-new adj 1.0 0)))
1565 (box-pack-start main-vbox frame t t 0)
1566 (setf (container-border-width vbox) 5)
1567 (container-add frame vbox)
1568 (box-pack-start vbox hbox nil t 5)
1570 (let* ((vbox2 (vbox-new nil 0))
1571 (label (label-new "Value :")))
1572 (box-pack-start hbox vbox2 t t 5)
1573 (setf (misc-xalign label) 0.0)
1574 (setf (misc-yalign label) 0.5)
1575 (box-pack-start vbox2 label nil t 0)
1576 (setf (spin-button-wrap-p spinner1) t)
1577 (setf (widget-width spinner1) 100)
1578 (setf (widget-height spinner1) 0)
1579 (box-pack-start vbox2 spinner1 nil t 0))
1581 (let* ((vbox2 (vbox-new nil 0))
1582 (label (label-new "Digits :")))
1583 (box-pack-start hbox vbox2 t t 5)
1584 (setf (misc-xalign label) 0.0)
1585 (setf (misc-yalign label) 0.5)
1586 (box-pack-start vbox2 label nil t 0)
1587 (setf (spin-button-wrap-p spinner2) t)
1588 (signal-connect adj 'value-changed
1591 (spin-button-digits spinner1)
1592 (floor (spin-button-value spinner2)))))
1593 (box-pack-start vbox2 spinner2 nil t 0))
1595 (let ((button (check-button-new "Snap to 0.5-ticks")))
1596 (signal-connect button 'clicked
1599 (spin-button-snap-to-ticks-p spinner1)
1600 (toggle-button-active-p button))))
1601 (box-pack-start vbox button t t 0)
1602 (setf (toggle-button-active-p button) t))
1604 (let ((button (check-button-new "Numeric only input mode")))
1605 (signal-connect button 'clicked
1608 (spin-button-numeric-p spinner1)
1609 (toggle-button-active-p button))))
1610 (box-pack-start vbox button t t 0)
1611 (setf (toggle-button-active-p button) t))
1613 (let ((val-label (label-new "0"))
1614 (hbox (hbox-new nil 0)))
1615 (box-pack-start vbox hbox nil t 5)
1616 (let ((button (button-new "Value as Int")))
1621 (label-label val-label)
1622 (format nil "~D" (spin-button-value-as-int spinner1)))))
1623 (box-pack-start hbox button t t 5))
1625 (let ((button (button-new "Value as Float")))
1630 (label-label val-label)
1632 (format nil "~~,~DF" (spin-button-digits spinner1))
1633 (spin-button-value spinner1)))))
1634 (box-pack-start hbox button t t 5))
1636 (box-pack-start vbox val-label t t 0)))
1638 (let ((hbox (hbox-new nil 0))
1639 (button (button-new "Close")))
1640 (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
1641 (box-pack-start main-vbox hbox nil t 0)
1642 (box-pack-start hbox button t t 5))))
1648 (define-test-window create-statusbar "Statusbar"
1649 (let ((statusbar (make-instance 'statusbar))
1650 (statusbar-counter 0)
1652 (create-button '("close" :can-default t) #'widget-destroy window)))
1655 statusbar 'text-popped
1656 #'(lambda (context-id text)
1657 (declare (ignore context-id))
1658 (format nil "Popped: ~A~%" text)))
1660 (make-instance 'vbox
1664 (make-instance 'vbox
1665 :border-width 10 :spacing 10
1673 (format nil "something ~D" (incf statusbar-counter)))))
1674 (create-button "pop" #'statusbar-pop statusbar 1)
1675 (create-button "steal #4" #'statusbar-remove statusbar 1 4)
1676 (create-button "dump stack")
1677 (create-button "test contexts")))
1678 (list (make-instance 'hseparator) :expand nil)
1680 (make-instance 'vbox
1682 :children (list (list close-button :expand nil)))
1686 (widget-grab-default close-button)))
1692 (define-standard-dialog create-idle-test "Idle Test"
1693 (let* ((container (make-instance 'hbox :parent main-box))
1694 (label (make-instance 'label
1695 :label "count: 0" :xpad 10 :ypad 10 :parent container))
1698 (declare (fixnum count))
1700 window 'destroy #'(lambda () (when idle (idle-remove idle))))
1702 (make-instance 'frame
1703 :label "Label Container" :border-width 5 :parent main-box
1705 (make-instance 'vbox
1707 (create-radio-button-group
1708 '(("Resize-Parent" :parent)
1709 ("Resize-Queue" :queue)
1710 ("Resize-Immediate" :immediate))
1712 '(setf container-resize-mode) container)))
1714 (make-instance 'button
1715 :label "start" :can-default t :parent action-area
1727 (setf (label-label label) (format nil "count: ~D" count))
1730 (make-instance 'button
1731 :label "stop" :can-default t :parent action-area
1739 (setq idle nil))))))))
1745 (define-standard-dialog create-timeout-test "Timeout Test"
1746 (let ((label (make-instance 'label
1747 :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1750 (declare (fixnum count))
1752 window 'destroy #'(lambda () (when timer (timeout-remove timer))))
1754 (make-instance 'button
1755 :label "start" :can-default t :parent action-area
1768 (setf (label-label label) (format nil "count: ~D" count))
1771 (make-instance 'button
1772 :label "stop" :can-default t :parent action-area
1779 (timeout-remove timer)
1780 (setq timer nil))))))))
1785 (define-standard-dialog create-toggle-buttons "Toggle Button"
1786 (setf (container-border-width main-box) 10)
1787 (setf (box-spacing main-box) 10)
1789 (make-instance 'toggle-button
1790 :label (format nil "Button~D" (1+ n)) :parent main-box)))
1796 (define-test-window create-toolbar "Toolbar test"
1797 (setf (window-allow-grow-p window) nil)
1798 (setf (window-allow-shrink-p window) t)
1799 (setf (window-auto-shrink-p window) t)
1800 (widget-realize window)
1802 (let ((toolbar (toolbar-new :horizontal :both)))
1803 (setf (toolbar-relief toolbar) :none)
1805 (toolbar-append-item
1806 toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
1807 :tooltip-text "Horizontal toolbar layout"
1808 :tooltip-private-text "Toolbar/Horizontal"
1809 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1811 (toolbar-append-item
1812 toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
1813 :tooltip-text "Vertical toolbar layout"
1814 :tooltip-private-text "Toolbar/Vertical"
1815 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1817 (toolbar-append-space toolbar)
1819 (toolbar-append-item
1820 toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
1821 :tooltip-text "Only show toolbar icons"
1822 :tooltip-private-text "Toolbar/IconsOnly"
1823 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1825 (toolbar-append-item
1826 toolbar "Text" (pixmap-new "clg:examples;test.xpm")
1827 :tooltip-text "Only show toolbar text"
1828 :tooltip-private-text "Toolbar/TextOnly"
1829 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1831 (toolbar-append-item
1832 toolbar "Both" (pixmap-new "clg:examples;test.xpm")
1833 :tooltip-text "Show toolbar icons and text"
1834 :tooltip-private-text "Toolbar/Both"
1835 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1837 (toolbar-append-space toolbar)
1839 (toolbar-append-widget
1841 :tooltip-text "This is an unusable GtkEntry ;)"
1842 :tooltip-private-text "Hey don't click me!")
1844 (toolbar-append-space toolbar)
1846 (toolbar-append-item
1847 toolbar "Small" (pixmap-new "clg:examples;test.xpm")
1848 :tooltip-text "Use small spaces"
1849 :tooltip-private-text "Toolbar/Small"
1850 :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1852 (toolbar-append-item
1853 toolbar "Big" (pixmap-new "clg:examples;test.xpm")
1854 :tooltip-text "Use big spaces"
1855 :tooltip-private-text "Toolbar/Big"
1856 :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1858 (toolbar-append-space toolbar)
1860 (toolbar-append-item
1861 toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
1862 :tooltip-text "Enable tooltips"
1863 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1865 (toolbar-append-item
1866 toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
1867 :tooltip-text "Disable tooltips"
1868 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1870 (toolbar-append-space toolbar)
1872 (toolbar-append-item
1873 toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1874 :tooltip-text "Show borders"
1875 :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1877 (toolbar-append-item
1879 "Borderless" (pixmap-new "clg:examples;test.xpm")
1880 :tooltip-text "Hide borders"
1881 :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1883 (toolbar-append-space toolbar)
1885 (toolbar-append-item
1886 toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1887 :tooltip-text "Empty spaces"
1888 :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1890 (toolbar-append-item
1891 toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1892 :tooltip-text "Lines in spaces"
1893 :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1895 (container-add window toolbar)))
1901 (define-standard-dialog create-tooltips "Tooltips"
1903 (window-allow-grow-p window) t
1904 (window-allow-shrink-p window) nil
1905 (window-auto-shrink-p window) t
1906 (widget-width window) 200
1907 (container-border-width main-box) 10
1908 (box-spacing main-box) 10)
1910 (let ((tooltips (tooltips-new)))
1911 (flet ((create-button (label tip-text tip-private)
1912 (let ((button (make-instance 'toggle-button
1913 :label label :parent main-box)))
1914 (tooltips-set-tip tooltips button tip-text tip-private)
1916 (create-button "button1" "This is button 1" "ContextHelp/button/1")
1917 (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")
1919 (let* ((toggle (create-button "Override TipSQuery Label"
1920 "Toggle TipsQuery view" "Hi msw! ;)"))
1921 (box (make-instance 'vbox
1922 :homogeneous nil :spacing 5 :border-width 5
1923 :parent (make-instance 'frame
1924 :label "ToolTips Inspector"
1925 :label-xalign 0.5 :border-width 0
1927 (button (make-instance 'button :label "[?]" :parent box))
1928 (tips-query (make-instance 'tips-query
1929 :caller button :parent box)))
1932 button 'clicked #'tips-query-start-query :object tips-query)
1935 tips-query 'widget-entered
1936 #'(lambda (widget tip-text tip-private)
1937 (declare (ignore widget tip-private))
1938 (when (toggle-button-active-p toggle)
1940 (label-label tips-query)
1943 "There is no Tip!"))
1944 (signal-emit-stop tips-query 'widget-entered))))
1947 tips-query 'widget-selected
1948 #'(lambda (widget tip-text tip-private event)
1949 (declare (ignore tip-text event))
1952 t "Help ~S requested for ~S~%"
1953 (or tip-private "None") (type-of widget)))
1957 tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1959 tooltips close-button "Push this button to close window"
1960 "ContextHelp/buttons/Close")))))
1966 (defun create-main-window ()
1967 (rc-parse "clg:examples;testgtkrc2")
1968 (rc-parse "clg:examples;testgtkrc")
1970 (let* ((button-specs
1971 '(("button box" create-button-box)
1972 ("buttons" create-buttons)
1973 ("calendar" create-calendar)
1974 ("check buttons" create-check-buttons)
1975 ("clist" #|create-clist|#)
1976 ("color selection" create-color-selection)
1977 ("ctree" #|create-ctree|#)
1978 ("cursors" #|create-cursors|#)
1979 ("dialog" create-dialog)
1981 ("entry" create-entry)
1983 ("file selection" create-file-selection)
1986 ("handle box" create-handle-box)
1988 ("labels" create-labels)
1989 ("layout" create-layout)
1990 ("list" create-list)
1991 ("menus" create-menus)
1993 ("notebook" create-notebook)
1994 ("panes" create-panes)
1995 ("pixmap" create-pixmap)
1998 ("progress bar" #|create-progress-bar|#)
1999 ("radio buttons" create-radio-buttons)
2000 ("range controls" create-range-controls)
2002 ("reparent" create-reparent)
2003 ("rulers" create-rulers)
2005 ("scrolled windows" create-scrolled-windows)
2006 ("shapes" create-shapes)
2007 ("spinbutton" create-spins)
2008 ("statusbar" create-statusbar)
2009 ("test idle" create-idle-test)
2013 ("test timeout" create-timeout-test)
2014 ("text" #|create-text|#)
2015 ("toggle buttons" create-toggle-buttons)
2016 ("toolbar" create-toolbar)
2017 ("tooltips" create-tooltips)
2018 ("tree" #|create-tree|#)
2020 (main-window (make-instance 'window
2021 :type :toplevel :title "testgtk.lisp"
2022 :name "main window" :x 20 :y 20 :width 200 :height 400
2023 :allow-grow nil :allow-shrink nil :auto-shrink nil))
2024 (scrolled-window (make-instance 'scrolled-window
2025 :hscrollbar-policy :automatic
2026 :vscrollbar-policy :automatic
2028 (close-button (create-button
2029 '("close" :can-default t)
2030 #'widget-destroy main-window)))
2033 (make-instance 'vbox
2038 (make-instance 'label :label (gtk-version)) :expand nil :fill nil)
2040 (make-instance 'label :label "clg CVS version") :expand nil :fill nil)
2042 (list (make-instance 'hseparator) :expand nil)
2044 (make-instance 'vbox
2045 :homogeneous nil :spacing 10 :border-width 10
2046 :children (list close-button))
2049 (scrolled-window-add-with-viewport
2051 (make-instance 'vbox
2053 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
2057 (apply #'create-button spec))
2060 (widget-grab-default close-button)
2061 (widget-show-all main-window)
2065 ;(create-main-window)