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.1 2000-08-14 16:44:26 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 (dialog-new))
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-vbox 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)
68 (defun build-option-menu (items history)
69 (let ((option-menu (option-menu-new))
71 (labels ((create-menu (items i group)
73 (let* ((item (first items))
74 (menu-item (radio-menu-item-new group (first item))))
78 (when (widget-mapped-p menu-item)
79 (funcall (second item)))))
81 (menu-append menu menu-item)
83 (setf (check-menu-item-active-p menu-item) t))
84 (widget-show menu-item)
86 (rest items) (1+ i) (radio-menu-item-group menu-item))))))
87 (create-menu items 0 nil))
88 (setf (option-menu-menu option-menu) menu)
89 (setf (option-menu-history option-menu) history)
94 ;;; Pixmaps used in some of the tests
136 (defvar book-closed-xpm
161 (defvar mini-page-xpm
184 (defvar book-open-xpm
211 (defun create-bbox (class title spacing child-w child-h layout)
212 (let* ((frame (make-instance 'frame :title title))
213 (bbox (make-instance 'class
219 (make-instance 'button :label "OK")
220 (make-instance 'button :label "Cancel")
221 (make-instance 'button :label "Help"))
223 (setf (button-box-child-size bbox) (vector child-w child-h))
227 (define-test-window create-button-box "Button Boxes"
228 (setf (container-border-width window) 10)
229 (let ((main-box (vbox-new nil 0)))
230 (let ((frame (frame-new "Horizontal Button Boxes"))
231 (box (vbox-new nil 0)))
232 (container-add window main-box)
233 (box-pack-start main-box frame t t 10)
234 (setf (container-border-width box) 10)
235 (container-add frame box)
237 box (create-bbox #'hbutton-box-new "Spread" 40 85 20 :spread) t t 0)
239 box (create-bbox #'hbutton-box-new "Edge" 40 85 20 :edge) t t 0)
241 box (create-bbox #'hbutton-box-new "Start" 40 85 20 :start) t t 0)
243 box (create-bbox #'hbutton-box-new "End" 40 85 20 :end) t t 0))
245 (let ((frame (frame-new "Vertical Button Boxes"))
246 (box (hbox-new nil 0)))
247 (box-pack-start main-box frame t t 10)
248 (setf (container-border-width box) 10)
249 (container-add frame box)
251 box (create-bbox #'vbutton-box-new "Spread" 30 85 20 :spread) t t 5)
253 box (create-bbox #'vbutton-box-new "Edge" 30 85 20 :edge) t t 5)
255 box (create-bbox #'vbutton-box-new "Start" 30 85 20 :start) t t 5)
257 box (create-bbox #'vbutton-box-new "End" 30 85 20 :end) t t 5))))
261 (define-standard-dialog create-buttons "Buttons"
262 (let ((table (table-new 3 3 nil))
263 (buttons `((,(button-new "button1") 0 1 0 1)
264 (,(button-new "button2") 1 2 1 2)
265 (,(button-new "button3") 2 3 2 3)
266 (,(button-new "button4") 0 1 2 3)
267 (,(button-new "button5") 2 3 0 1)
268 (,(button-new "button6") 1 2 2 3)
269 (,(button-new "button7") 1 2 0 1)
270 (,(button-new "button8") 2 3 1 2)
271 (,(button-new "button9") 0 1 1 2))))
272 (setf (table-row-spacings table) 5)
273 (setf (table-column-spacings table) 5)
274 (setf (container-border-width table) 10)
275 (box-pack-start main-box table t t 0)
276 (do ((tmp buttons (rest tmp)))
278 (let ((button (first tmp))
279 (widget (or (first (second tmp))
280 (first (first buttons)))))
281 (signal-connect (first button) 'clicked
283 (if (widget-visible-p widget)
285 (widget-show widget))))
286 (apply #'table-attach table button)))))
291 (define-standard-dialog create-calendar "Calendar"
292 (setf (container-border-width main-box) 10)
293 (box-pack-start main-box (calendar-new) t t 0))
299 (define-standard-dialog create-check-buttons "GtkCheckButton"
300 (setf (container-border-width main-box) 10)
301 (setf (box-spacing main-box) 10)
302 (box-pack-start main-box (check-button-new "button1") t t 0)
303 (box-pack-start main-box (check-button-new "button2") t t 0)
304 (box-pack-start main-box (check-button-new "button3") t t 0))
313 (defun insert-row-clist (clist)
314 (let* ((text '("This" "is" "an" "inserted" "row"
315 "This" "is" "an" "inserted" "row"
316 "This" "is" "an" "inserted" "row"
317 "This" "is" "an" "inserted" "row"))
319 (if (clist-focus-row clist)
320 (clist-insert clist (clist-focus-row clist) text)
321 (clist-prepend clist text))))
324 (let ((color1 '#(0 56000 0))
325 (color2 '#(32000 0 56000)))
326 (setq style1 (style-copy (widget-style clist)))
328 (style-base style1 :normal) color1
329 (style-base style1 :selected) color2)
331 (setq style2 (style-copy (widget-style clist)))
333 (style-fg style2 :normal) color1
334 (style-fg style2 :selected) color2)
336 (setq style3 (style-copy (widget-style clist)))
338 (style-fg style3 :normal) color1
339 (style-base style3 :normal) color2
340 (style-font style3) "-*-courier-medium-*-*-*-*-120-*-*-*-*-*-*")))
342 (setf (clist-cell-style clist row 3) style1)
343 (setf (clist-cell-style clist row 4) style2)
344 (setf (clist-cell-style clist row 0) style3))))
347 (define-standard-dialog create-clist "clist"
348 (let* ((titles '("auto resize" "not resizeable" "max width 100"
349 "min width 50" "hide column" "Title 5" "Title 6"
350 "Title 7" "Title 8" "Title 9" "Title 10"
351 "Title 11" "Title 12" "Title 13" "Title 14"
352 "Title 15" "Title 16" "Title 17" "Title 18"
354 (clist (clist-new titles))
355 (scrolled-window (scrolled-window-new nil nil)))
357 (setf (container-border-width scrolled-window) 5)
358 (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
359 (container-add scrolled-window clist)
366 (setf (clist-column-visible-p clist column) nil))
367 ((= column (clist-sort-column clist))
368 (if (eq (clist-sort-type clist) :ascending)
369 (setf (clist-sort-type clist) :descending)
370 (setf (clist-sort-type clist) :ascending)))
372 (setf (clist-sort-column clist) column)))
375 (let ((box2 (hbox-new nil 5)))
376 (setf (container-border-width box2) 5)
377 (box-pack-start main-box box2 nil nil 0)
379 (let ((button (button-new "Insert Row")))
380 (box-pack-start box2 button t t 0)
382 button 'clicked #'insert-row-clist :object clist))
384 (let ((button (button-new "Add 1,000 Rows With Pixmaps")))
385 (box-pack-start box2 button t t 0)
389 (multiple-value-bind (pixmap mask)
390 (gdk:pixmap-create gtk-mini-xpm)
391 (let ((texts (do ((i 4 (1+ i))
392 (texts '(nil "Center" "Right")))
393 ((= i (length titles)) (reverse texts))
394 (push (format nil "Column ~D" i) texts))))
400 (cons (format nil "CListRow ~D" (random 1000))
402 (clist-set-cell-pixtext
403 clist row 3 "gtk+" 5 (list pixmap mask))))
404 (clist-thaw clist))))))
406 (let ((button (button-new "Add 10,000 Rows")))
407 (box-pack-start box2 button t t 0)
411 (let ((texts (do ((i 3 (1+ i))
412 (texts '("Center" "Right")))
413 ((= i (length titles)) (reverse texts))
414 (push (format nil "Column ~D" i) texts))))
418 clist (cons (format nil "CListRow ~D" (random 1000)) texts)))
419 (clist-thaw clist))))))
422 (let ((box2 (hbox-new nil 5)))
423 (setf (container-border-width box2) 5)
424 (box-pack-start main-box box2 nil nil 0)
426 (let ((button (button-new "Clear List")))
427 (box-pack-start box2 button t t 0)
431 (clist-clear clist))))
433 (let ((button (button-new "Remove Selection")))
434 (box-pack-start box2 button t t 0)
439 (let ((selection-mode (clist-selection-mode clist)))
440 (labels ((remove-selection ()
441 (let ((selection (clist-selection clist)))
443 (clist-remove clist (first selection))
444 (unless (eq selection-mode :browse)
445 (remove-selection))))))
449 (eq selection-mode :extended)
450 (not (clist-selection clist))
451 (clist-focus-row clist))
452 (clist-select-row clist (clist-focus-row clist))))
453 (clist-thaw clist))))
455 (let ((button (button-new "Undo Selection")))
456 (box-pack-start box2 button t t 0)
458 button 'clicked #'clist-undo-selection :object clist))
460 (let ((button (button-new "Warning Test")))
461 (box-pack-start box2 button t t 0)
462 (signal-connect button 'clicked #'(lambda ()))))
465 (let ((box2 (hbox-new nil 5)))
466 (setf (container-border-width box2) 5)
467 (box-pack-start main-box box2 nil nil 0)
469 (let ((button (check-button-new "Show Title Buttons")))
470 (box-pack-start box2 button t t 0)
474 (if (toggle-button-active-p button)
475 (clist-column-titles-show clist)
476 (clist-column-titles-hide clist))))
477 (setf (toggle-button-active-p button) t))
479 (let ((button (check-button-new "Reorderable")))
480 (box-pack-start box2 button nil t 0)
485 (clist-reorderable-p clist) (toggle-button-active-p button))))
486 (setf (toggle-button-active-p button) t))
488 (box-pack-start box2 (label-new "Selection Mode : ") nil t 0)
492 ,#'(lambda () (setf (clist-selection-mode clist) :single)))
494 ,#'(lambda () (setf (clist-selection-mode clist) :browse)))
496 ,#'(lambda () (setf (clist-selection-mode clist) :multiple)))
498 ,#'(lambda () (setf (clist-selection-mode clist) :extended))))
500 (box-pack-start box2 option-menu nil t 0)))
502 (box-pack-start main-box scrolled-window t t 0)
503 (setf (clist-row-height clist) 18)
504 (setf (widget-height clist) 300)
506 (dotimes (i (length titles))
507 (setf (clist-column-width clist i) 80))
509 (setf (clist-column-auto-resize-p clist 0) t)
510 (setf (clist-column-resizeable-p clist 1) nil)
511 (setf (clist-column-max-width clist 2) 100)
512 (setf (clist-column-min-width clist 3) 50)
513 (setf (clist-selection-mode clist) :extended)
514 (setf (clist-column-justification clist 1) :right)
515 (setf (clist-column-justification clist 2) :center)
517 (let ((style (style-new))
518 (texts (do ((i 3 (1+ i))
519 (texts '("Center" "Right")))
520 ((= i (length titles)) (reverse texts))
521 (push (format nil "Column ~D" i) texts))))
523 (style-font style) "-adobe-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*"
524 (style-fg style :normal) '#(56000 0 0)
525 (style-base style :normal) '#(0 56000 32000))
528 (clist-append clist (cons (format nil "CListRow ~D" i) texts))
530 (setf (clist-row-style clist i) style)
531 (setf (clist-cell-style clist i (mod i 4)) style))))))
537 (let ((color-dialog nil))
538 (defun create-color-selection ()
541 (color-selection-dialog-new "color selection dialog"))
543 (setf (window-position color-dialog) :mouse)
545 color-dialog 'destroy #'(lambda () (widget-destroyed color-dialog)))
547 (let ((colorsel (color-selection-dialog-colorsel color-dialog)))
548 (setf (color-selection-use-opacity-p colorsel) t)
549 (setf (color-selection-policy colorsel) :continuous)
551 ; (signal-connect colorsel 'color-changed #'(lambda () nil))
553 (let ((button (color-selection-dialog-ok-button color-dialog)))
557 (let ((color (color-selection-color colorsel)))
558 (format t "Selected color: ~A~%" color)
559 (setf (color-selection-color colorsel) color))))))
561 (let ((button (color-selection-dialog-cancel-button color-dialog)))
563 button 'clicked #'widget-destroy :object color-dialog)))
565 (if (not (widget-visible-p color-dialog))
566 (widget-show-all color-dialog)
567 (widget-destroy color-dialog))))
573 (let ((total-pages 0)
582 (defun after-press (ctree &rest data)
583 (declare (ignore data))
585 (label-text (svref status-labels 0))
586 (format nil "~D" total-books))
588 (label-text (svref status-labels 1))
589 (format nil "~D" total-pages))
591 (label-text (svref status-labels 2))
592 (format nil "~D" (length (clist-selection ctree))))
594 (label-text (svref status-labels 3))
595 (format nil "~D" (clist-n-rows ctree)))
598 (defun build-recursive (ctree parent current-depth depth books pages)
600 (do ((i (+ pages books) (1- i)))
609 (format nil "Page ~D" (random 100))
610 (format nil "Item ~D-~D" current-depth i))
611 5 :pixmap pixmap3 :leaf t))
612 (when (and parent (eq (ctree-line-style ctree) :tabbed))
614 (ctree-row-style ctree sibling)
615 (ctree-row-style ctree parent))))
617 (unless (= current-depth depth)
618 (do ((i books (1- i)))
626 (format nil "Book ~D" (random 100))
627 (format nil "Item ~D-~D" current-depth i))
628 5 :closed pixmap1 :opened pixmap2))
630 (let ((style (style-new))
631 (color (case (mod current-depth 3)
633 (* 10000 (mod current-depth 6))
635 (- 65535 (mod (* i 10000) 65535))))
637 (* 10000 (mod current-depth 6))
638 (- 65535 (mod (* i 10000) 65535))
641 (- 65535 (mod (* i 10000) 65535))
643 (* 10000 (mod current-depth 6)))))))
644 (setf (style-base style :normal) color)
645 (ctree-set-node-data ctree sibling style #'style-unref)
647 (when (eq (ctree-line-style ctree) :tabbed)
648 (setf (ctree-row-style ctree sibling) style)))
651 ctree sibling (1+ current-depth) depth books pages)))))
653 (defun rebuild-tree (ctree depth books pages)
654 (let ((n (* (/ (1- (expt books depth)) (1- books)) (1+ pages))))
656 (format t "~D total items? Try less~%" n)
664 ctree nil nil '("Root") 5
665 :closed pixmap1 :opened pixmap2 :expanded t))
667 (setf (style-base style :normal) '#(0 45000 55000))
668 (ctree-set-node-data ctree parent style #'style-unref)
670 (when (eq (ctree-line-style ctree) :tabbed)
671 (setf (ctree-row-style ctree parent) style))
673 (build-recursive ctree parent 1 depth books pages)
675 (after-press ctree))))))
677 (let ((export-window)
679 (defun export-tree (ctree)
680 (unless export-window
681 (setq export-window (window-new :toplevel))
683 export-window 'destroy
685 (widget-destroyed export-window)))
687 (setf (window-title export-window) "Exported ctree")
688 (setf (container-border-width export-window) 5)
690 (let ((vbox (vbox-new nil 0)))
691 (container-add export-window vbox)
693 (let ((button (button-new "Close")))
694 (box-pack-end vbox button nil t 0)
696 button 'clicked #'widget-destroy :object export-window))
698 (box-pack-end vbox (hseparator-new) nil t 10)
700 (setq export-ctree (ctree-new '("Tree" "Info")))
701 (setf (ctree-line-style export-ctree) :dotted)
703 (let ((scrolled-window (scrolled-window-new)))
704 (container-add scrolled-window export-ctree)
706 (scrolled-window-scrollbar-policy scrolled-window) :automatic)
707 (box-pack vbox scrolled-window)
708 (setf (clist-selection-mode export-ctree) :extended)
709 (setf (clist-column-width export-ctree 0) 200)
710 (setf (clist-column-width export-ctree 1) 200)
711 (setf (widget-width export-ctree) 300)
712 (setf (widget-height export-ctree) 200))))
714 (unless (widget-visible-p export-window)
715 (widget-show-all export-window))
717 (clist-clear export-ctree)
718 (let ((node (ctree-nth-node ctree (clist-focus-row ctree))))
721 (list (ctree-map-to-list ctree node #'(lambda (node) node)))))
722 (ctree-insert-from-list
723 export-ctree nil tree-list
724 #'(lambda (export-ctree-node ctree-node)
726 (text spacing pixmap-closed bitmap-closed pixmap-opened
727 bitmap-opened leaf expanded)
728 (ctree-node-info ctree ctree-node)
730 export-ctree export-ctree-node text spacing
731 :closed (list pixmap-closed bitmap-closed)
732 :opened (list pixmap-opened bitmap-opened)
733 :leaf leaf :expanded expanded))
734 (unless (eq (ctree-cell-type ctree ctree-node 1) :empty)
736 (ctree-cell-text export-ctree export-ctree-node 1)
737 (ctree-cell-text ctree ctree-node 1))))))))))
740 (define-test-window create-ctree "CTree"
741 (let ((vbox (vbox-new nil 0))
742 (ctree (ctree-new '("Tree" "Info"))))
744 (container-add window vbox)
746 (let ((hbox (hbox-new nil 5)))
747 (setf (container-border-width hbox) 5)
748 (box-pack-start vbox hbox nil t 0)
750 (let ((spin1 (spin-button-new (adjustment-new 4 1 10 1 5 0) 0 0))
751 (spin2 (spin-button-new (adjustment-new 3 1 20 1 5 0) 0 0))
752 (spin3 (spin-button-new (adjustment-new 5 1 20 1 5 0) 0 0)))
754 (box-pack-start hbox (label-new "Depth :") nil t 0)
755 (box-pack-start hbox spin1 nil t 5)
756 (box-pack-start hbox (label-new "Books :") nil t 0)
757 (box-pack-start hbox spin2 nil t 5)
758 (box-pack-start hbox (label-new "Pages :") nil t 0)
759 (box-pack-start hbox spin3 nil t 5)
761 (let ((button (button-new "Rebuild Tree")))
762 (box-pack-start hbox button t t 0)
766 (let ((depth (spin-button-value-as-int spin1))
767 (books (spin-button-value-as-int spin2))
768 (pages (spin-button-value-as-int spin3)))
769 (rebuild-tree ctree depth books pages))))))
771 (let ((button (button-new "Close")))
772 (box-pack-end hbox button t t 0)
773 (signal-connect button 'clicked #'widget-destroy :object window)))
775 (let ((scrolled-window (scrolled-window-new)))
776 (setf (container-border-width scrolled-window) 5)
777 (setf (scrolled-window-hscrollbar-policy scrolled-window) :automatic)
778 (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
779 (box-pack-start vbox scrolled-window t t 0)
781 (container-add scrolled-window ctree)
782 (setf (clist-column-auto-resize-p ctree 0) t)
783 (setf (clist-column-width ctree 1) 200)
784 (setf (clist-selection-mode ctree) :extended)
785 (setf (ctree-line-style ctree) :dotted))
791 ((/= column (clist-sort-column ctree))
792 (setf (clist-sort-column ctree) column))
793 ((eq (clist-sort-type ctree) :ascending)
794 (setf (clist-sort-type ctree) :descending))
795 (t (setf (clist-sort-type ctree) :ascending)))
796 (ctree-sort-recursive ctree)))
799 ctree 'button-press-event #'after-press :object t :after t)
801 ctree 'button-release-event #'after-press :object t :after t)
803 ctree 'tree-move #'after-press :object t :after t)
805 ctree 'end-selection #'after-press :object t :after t)
807 ctree 'toggle-focus-row #'after-press :object t :after t)
809 ctree 'select-all #'after-press :object t :after t)
811 ctree 'unselect-all #'after-press :object t :after t)
813 ctree 'scroll-vertical #'after-press :object t :after t)
815 (let ((bbox (hbox-new nil 5)))
816 (setf (container-border-width bbox) 5)
817 (box-pack-start vbox bbox nil t 0)
819 (let ((mbox (vbox-new t 5)))
820 (box-pack bbox mbox :expand nil)
821 (box-pack mbox (label-new "Row Height :") :expand nil :fill nil)
822 (box-pack mbox (label-new "Indent :") :expand nil :fill nil)
823 (box-pack mbox (label-new "Spacing :") :expand nil :fill nil))
825 (let ((mbox (vbox-new t 5)))
826 (box-pack bbox mbox :expand nil)
828 (let* ((adjustment (adjustment-new 20 12 100 1 10 0))
829 (spinner (spin-button-new adjustment 0 0)))
830 (box-pack mbox spinner :expand nil :fill nil :padding 5)
831 (flet ((set-row-height ()
833 (clist-row-height ctree)
834 (spin-button-value-as-int spinner))))
835 (signal-connect adjustment 'value-changed #'set-row-height)
838 (let* ((adjustment (adjustment-new 20 0 60 1 10 0))
839 (spinner (spin-button-new adjustment 0 0)))
840 (box-pack mbox spinner :expand nil :fill nil :padding 5)
841 (flet ((set-indent ()
844 (spin-button-value-as-int spinner))))
845 (signal-connect adjustment 'value-changed #'set-indent)
848 (let* ((adjustment (adjustment-new 5 0 60 1 10 0))
849 (spinner (spin-button-new adjustment 0 0)))
850 (box-pack mbox spinner :expand nil :fill nil :padding 5)
851 (flet ((set-spacing ()
853 (ctree-spacing ctree)
854 (spin-button-value-as-int spinner))))
855 (signal-connect adjustment 'value-changed #'set-spacing)
859 (let ((mbox (vbox-new t 5)))
860 (box-pack bbox mbox :expand nil)
862 (let ((hbox (hbox-new nil 5)))
863 (box-pack mbox hbox :expand nil :fill nil)
865 (let ((button (button-new "Expand All")))
866 (box-pack hbox button)
870 (ctree-expand-recursive ctree nil)
871 (after-press ctree))))
873 (let ((button (button-new "Collapse All")))
874 (box-pack hbox button)
878 (ctree-collapse-recursive ctree nil)
879 (after-press ctree))))
881 (let ((button (button-new "Change Style")))
882 (box-pack hbox button)
886 (let ((node (ctree-nth-node
887 ctree (or (clist-focus-row ctree) 0))))
890 (let ((color1 '#(0 56000 0))
891 (color2 '#(32000 0 56000)))
892 (setq style1 (style-new))
893 (setf (style-base style1 :normal) color1)
894 (setf (style-fg style1 :selected) color2)
896 (setq style2 (style-new))
897 (setf (style-base style2 :selected) color2)
898 (setf (style-base style2 :normal) color2)
899 (setf (style-fg style2 :normal) color1)
902 "-*-courier-medium-*-*-*-*-300-*-*-*-*-*-*")))
903 (setf (ctree-cell-style ctree node 1) style1)
904 (setf (ctree-cell-style ctree node 0) style2)
906 (when (ctree-node-child node)
908 (ctree-row-style ctree (ctree-node-child node))
911 (let ((button (button-new "Export Tree")))
912 (box-pack hbox button)
913 (signal-connect button 'clicked #'export-tree :object ctree)))
915 (let ((hbox (hbox-new nil 5)))
916 (box-pack mbox hbox :expand nil :fill nil)
918 (let ((button (button-new "Select All")))
919 (box-pack hbox button)
923 (ctree-select-recursive ctree nil)
924 (after-press ctree))))
926 (let ((button (button-new "Unselect All")))
927 (box-pack hbox button)
931 (ctree-unselect-recursive ctree nil)
932 (after-press ctree))))
934 (let ((button (button-new "Remove Selection")))
935 (box-pack hbox button)
940 (let ((selection-mode (clist-selection-mode ctree)))
942 ((remove-selection ()
943 (let ((node (first (ctree-selection ctree))))
946 (ctree-apply-post-recursive
949 (if (ctree-node-leaf-p node)
951 (decf total-books))))
953 (ctree-remove-node ctree node)
954 (unless (eq selection-mode :browse)
955 (remove-selection))))))
959 (eq selection-mode :extended)
960 (not (clist-selection ctree))
961 (clist-focus-row ctree))
964 (ctree-nth-node ctree (clist-focus-row ctree)))))
966 (after-press ctree))))
968 (let ((button (check-button-new "Reorderable")))
969 (box-pack hbox button :expand nil)
974 (clist-reorderable-p ctree)
975 (toggle-button-active-p button))))
976 (setf (toggle-button-active-p button) t)))
978 (let ((hbox (hbox-new nil 5)))
979 (box-pack mbox hbox :expand nil :fill nil)
982 ((set-line-style (line-style)
983 (let ((current-line-style (ctree-line-style ctree)))
986 (eq current-line-style :tabbed)
987 (not (eq line-style :tabbed)))
989 (not (eq current-line-style :tabbed))
990 (eq line-style :tabbed)))
991 (ctree-apply-pre-recursive
997 ((eq (ctree-line-style ctree) :tabbed) nil)
998 ((not (ctree-node-leaf-p node))
999 (ctree-node-data ctree node))
1000 ((ctree-node-parent node)
1002 ctree (ctree-node-parent node))))))
1003 (setf (ctree-row-style ctree node) style))))
1004 (setf (ctree-line-style ctree) line-style)))))
1008 `(("No lines" ,#'(lambda () (set-line-style :none)))
1009 ("Solid" ,#'(lambda () (set-line-style :solid)))
1010 ("Dotted" ,#'(lambda () (set-line-style :dotted)))
1011 ("Tabbed" ,#'(lambda () (set-line-style :tabbed))))
1013 (box-pack hbox option-menu :expand nil)))
1019 (setf (ctree-expander-style ctree) :none)))
1022 (setf (ctree-expander-style ctree) :square)))
1025 (setf (ctree-expander-style ctree) :triangle)))
1028 (setf (ctree-expander-style ctree) :circular))))
1030 (box-pack hbox option-menu :expand nil))
1037 (clist-column-justification ctree 0) :left)))
1041 (clist-column-justification ctree 0) :right))))
1043 (box-pack hbox option-menu :expand nil))
1045 (flet ((set-sel-mode (mode)
1046 (setf (clist-selection-mode ctree) mode)
1047 (after-press ctree)))
1050 `(("Single" ,#'(lambda () (set-sel-mode :single)))
1051 ("Browse" ,#'(lambda () (set-sel-mode :browse)))
1052 ("Multiple" ,#'(lambda () (set-sel-mode :multiple)))
1053 ("Extended" ,#'(lambda () (set-sel-mode :extended))))
1055 (box-pack hbox option-menu :expand nil))))))
1057 (let ((frame (frame-new)))
1058 (setf (container-border-width frame) 0)
1059 (setf (frame-shadow-type frame) :out)
1060 (box-pack vbox frame :expand nil)
1062 (let ((hbox (hbox-new t 2)))
1063 (setf (container-border-width hbox) 2)
1064 (container-add frame hbox)
1070 (let ((frame (frame-new))
1071 (hbox2 (hbox-new nil 0)))
1072 (setf (frame-shadow-type frame) :in)
1073 (box-pack hbox frame :expand nil)
1074 (setf (container-border-width hbox2) 2)
1075 (container-add frame hbox2)
1076 (box-pack hbox2 (label-new text) :expand nil)
1077 (let ((label (label-new "")))
1078 (box-pack-end hbox2 label nil t 5)
1080 '("Books :" "Pages :" "Selected :" "Visible :")))))
1082 (widget-realize window)
1083 (let ((gdk:window (widget-window window)))
1084 (setq pixmap1 (multiple-value-list
1085 (gdk:pixmap-create book-closed-xpm :window gdk:window)))
1086 (setq pixmap2 (multiple-value-list
1087 (gdk:pixmap-create book-open-xpm :window gdk:window)))
1088 (setq pixmap3 (multiple-value-list
1089 (gdk:pixmap-create mini-page-xpm :window gdk:window))))
1090 (setf (widget-height ctree) 300)
1092 (rebuild-tree ctree 4 3 5))))
1098 (defun clamp (n min-val max-val)
1099 (declare (number n min-val max-val))
1100 (max (min n max-val) min-val))
1102 (defun set-cursor (spinner drawing-area label)
1105 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
1107 (setf (label-text label) (string-downcase (symbol-name cursor)))
1108 (setf (widget-cursor drawing-area) cursor)))
1111 (define-standard-dialog create-cursors "Cursors"
1112 (setf (container-border-width main-box) 10)
1113 (setf (box-spacing main-box) 5)
1114 (let* ((hbox (hbox-new nil 0))
1115 (label (label-new "Cursor Value : "))
1116 (adj (adjustment-new 0 0 152 2 10 0))
1117 (spinner (spin-button-new adj 0 0)))
1118 (setf (container-border-width hbox) 5)
1119 (box-pack-start main-box hbox nil t 0)
1120 (setf (misc-xalign label) 0)
1121 (setf (misc-yalign label) 0.5)
1122 (box-pack-start hbox label nil t 0)
1123 (box-pack-start hbox spinner t t 0)
1125 (let ((frame (make-frame
1126 :shadow-type :etched-in
1128 :label "Cursor Area"
1132 (drawing-area (drawing-area-new)))
1133 (setf (widget-width drawing-area) 80)
1134 (setf (widget-height drawing-area) 80)
1135 (container-add frame drawing-area)
1137 drawing-area 'expose-event
1139 (declare (ignore event))
1140 (multiple-value-bind (width height)
1141 (drawing-area-size drawing-area)
1142 (let* ((drawable (widget-window drawing-area))
1143 (style (widget-style drawing-area))
1144 (white-gc (style-get-gc style :white))
1145 (gray-gc (style-get-gc style :background :normal))
1146 (black-gc (style-get-gc style :black)))
1148 drawable white-gc t 0 0 width (floor height 2))
1150 drawable black-gc t 0 (floor height 2) width (floor height 2))
1152 drawable gray-gc t (floor width 3) (floor height 3)
1153 (floor width 3) (floor height 3))))
1155 (setf (widget-events drawing-area) '(:exposure :button-press))
1157 drawing-area 'button-press-event
1160 (eq (gdk:event-type event) :button-press)
1162 (= (gdk:event-button event) 1)
1163 (= (gdk:event-button event) 3)))
1166 (if (= (gdk:event-button event) 1)
1171 (widget-show drawing-area)
1173 (let ((label (make-label
1177 (setf (box-child-expand-p #|main-box|# label) nil)
1181 (set-cursor spinner drawing-area label)))
1183 (widget-realize drawing-area)
1184 (set-cursor spinner drawing-area label)))))
1190 (define-test-dialog create-dialog "Dialog"
1191 (setf (widget-width window) 200)
1192 (setf (widget-height window) 110)
1194 (let ((button (button-new "OK")))
1195 (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
1196 (setf (widget-can-default-p button) t)
1197 (box-pack-start action-area button t t 0)
1198 (widget-grab-default button)
1199 (widget-show button))
1201 (let ((button (button-new "Toggle"))
1208 (setq label (label-new "Dialog Test"))
1209 (signal-connect label 'destroy #'widget-destroy :object label)
1210 (setf (misc-xpad label) 10)
1211 (setf (misc-ypad label) 10)
1212 (box-pack-start main-box label t t 0)
1213 (widget-show label))
1215 (widget-destroy label)
1216 (setq label nil)))))
1217 (setf (widget-can-default-p button) t)
1218 (box-pack-start action-area button t t 0)
1219 (widget-grab-default button)
1220 (widget-show button)))
1226 (define-standard-dialog create-entry "Entry"
1227 (setf (container-border-width main-box) 10)
1228 (setf (box-spacing main-box) 10)
1229 (let ((entry (make-instance 'entry
1232 :parent (list main-box :fill t :expand t))))
1233 (entry-select-region entry 0 5)
1235 (let ((combo (make-instance 'combo
1237 :parent (list main-box :expand t :fill t))))
1239 (combo-popdown-strings combo)
1243 "item3 item3 item3 item3"
1244 "item4 item4 item4 item4 item4"
1245 "item5 item5 item5 item5 item5 item5"
1246 "item6 item6 item6 item6 item6"
1247 "item7 item7 item7 item7"
1250 (editable-select-region entry 0 5))
1252 (let ((check-button (check-button-new "Editable")))
1253 (box-pack-start main-box check-button nil t 0)
1255 check-button 'toggled
1258 (editable-editable-p entry)
1259 (toggle-button-active-p check-button))))
1260 (setf (toggle-button-active-p check-button) t)
1261 (widget-show check-button))
1263 (let ((check-button (check-button-new "Visible")))
1264 (box-pack-start main-box check-button nil t 0)
1266 check-button 'toggled
1269 (entry-visible-p entry)
1270 (toggle-button-active-p check-button))))
1271 (setf (toggle-button-active-p check-button) t)
1272 (widget-show check-button))
1274 (let ((check-button (check-button-new "Sensitive")))
1275 (box-pack-start main-box check-button nil t 0)
1277 check-button 'toggled
1280 (widget-sensitive-p entry)
1281 (toggle-button-active-p check-button))))
1282 (setf (toggle-button-active-p check-button) t)
1283 (widget-show check-button))))
1287 ;; File selecetion dialog
1289 (let ((filesel nil))
1290 (defun create-file-selection ()
1292 (setq filesel (file-selection-new "file selection dialog"))
1293 (file-selection-hide-fileop-buttons filesel)
1294 (setf (window-position filesel) :mouse)
1296 filesel 'destroy #'(lambda () (widget-destroyed filesel)))
1298 (file-selection-ok-button filesel) 'clicked
1301 t "Selected file: ~A~%" (file-selection-filename filesel))
1302 (widget-destroy filesel)))
1304 (file-selection-cancel-button filesel) 'clicked
1305 #'widget-destroy :object filesel)
1307 (let ((button (button-new "Hide Fileops")))
1310 #'file-selection-hide-fileop-buttons :object filesel)
1311 (box-pack-start (file-selection-action-area filesel) button nil nil 0)
1312 (widget-show button))
1314 (let ((button (button-new "Show Fileops")))
1317 #'file-selection-show-fileop-buttons :object filesel)
1318 (box-pack-start (file-selection-action-area filesel) button nil nil 0)
1319 (widget-show button)))
1321 (if (not (widget-visible-p filesel))
1322 (widget-show-all filesel)
1323 (widget-destroy filesel))))
1329 (defun create-handle-box-toolbar ()
1330 (let ((toolbar (toolbar-new :horizontal :both)))
1331 (toolbar-append-item
1332 toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
1333 :tooltip-text "Horizontal toolbar layout"
1334 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1336 (toolbar-append-item
1337 toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm")
1338 :tooltip-text "Vertical toolbar layout"
1339 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1341 (toolbar-append-space toolbar)
1343 (toolbar-append-item
1344 toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm")
1345 :tooltip-text "Only show toolbar icons"
1346 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1348 (toolbar-append-item
1349 toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
1350 :tooltip-text "Only show toolbar text"
1351 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1353 (toolbar-append-item
1354 toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm")
1355 :tooltip-text "Show toolbar icons and text"
1356 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1358 (toolbar-append-space toolbar)
1360 (toolbar-append-item
1361 toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm")
1362 :tooltip-text "Use small spaces"
1363 :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1365 (toolbar-append-item
1366 toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm")
1367 :tooltip-text "Use big spaces"
1368 :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1370 (toolbar-append-space toolbar)
1372 (toolbar-append-item
1373 toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm")
1374 :tooltip-text "Enable tooltips"
1375 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1377 (toolbar-append-item
1378 toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
1379 :tooltip-text "Disable tooltips"
1380 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1382 (toolbar-append-space toolbar)
1384 (toolbar-append-item
1385 toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
1386 :tooltip-text "Show borders"
1387 :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1389 (toolbar-append-item
1390 toolbar "Borderless" (pixmap-new "cl-gtk:src;test.xpm")
1391 :tooltip-text "Hide borders"
1392 :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1397 (defun handle-box-child-signal (handle-box child action)
1398 (format t "~S: child ~S ~A~%" handle-box child action))
1401 (define-test-window create-handle-box "Handle Box Test"
1402 (setf (window-allow-grow-p window) t)
1403 (setf (window-allow-shrink-p window) t)
1404 (setf (window-auto-shrink-p window) nil)
1405 (setf (container-border-width window) 20)
1406 (let ((vbox (vbox-new nil 0)))
1407 (container-add window vbox)
1409 (container-add vbox (label-new "Above"))
1410 (container-add vbox (hseparator-new))
1412 (let ((hbox (hbox-new nil 10)))
1413 (container-add vbox hbox)
1415 (let ((handle-box (handle-box-new)))
1416 (box-pack-start hbox handle-box nil nil 0)
1418 handle-box 'child-attached
1420 (handle-box-child-signal handle-box child "attached")))
1422 handle-box 'child-detached
1424 (handle-box-child-signal handle-box child "detached")))
1425 (container-add handle-box (create-handle-box-toolbar)))
1427 (let ((handle-box (handle-box-new)))
1428 (box-pack-start hbox handle-box nil nil 0)
1430 handle-box 'child-attached
1432 (handle-box-child-signal handle-box child "attached")))
1434 handle-box 'child-detached
1436 (handle-box-child-signal handle-box child "detached")))
1438 (let ((handle-box2 (handle-box-new)))
1439 (container-add handle-box handle-box2)
1441 handle-box2 'child-attached
1443 (handle-box-child-signal handle-box child "attached")))
1445 handle-box2 'child-detached
1447 (handle-box-child-signal handle-box child "detached")))
1448 (container-add handle-box2 (label-new "Foo!")))))
1450 (container-add vbox (hseparator-new))
1451 (container-add vbox (label-new "Below"))))
1457 (define-test-window create-labels "Labels"
1458 (setf (container-border-width window) 5)
1459 (let ((hbox (hbox-new nil 5)))
1460 (container-add window hbox)
1461 (let ((vbox (vbox-new nil 5)))
1462 (box-pack-start hbox vbox nil nil 0)
1464 (let ((frame (frame-new "Normal Label")))
1465 (container-add frame (label-new "This is a Normal label"))
1466 (box-pack-start vbox frame nil nil 0))
1468 (let ((frame (frame-new "Multi-line Label")))
1469 (container-add frame (label-new
1470 "This is a Multi-line label.
1473 (box-pack-start vbox frame nil nil 0))
1475 (let ((frame (frame-new "Left Justified Label"))
1477 "This is a Left-Justified
1480 (setf (label-justify label) :left)
1481 (container-add frame label)
1482 (box-pack-start vbox frame nil nil 0))
1484 (let ((frame (frame-new "Right Justified Label"))
1486 "This is a Right-Justified
1489 (setf (label-justify label) :right)
1490 (container-add frame label)
1491 (box-pack-start vbox frame nil nil 0)))
1493 (let ((vbox (vbox-new nil 5)))
1494 (box-pack-start hbox vbox nil nil 0)
1496 (let ((frame (frame-new "Line wrapped label"))
1498 "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.
1499 It supports multiple paragraphs correctly, and correctly adds many extra spaces. ")))
1500 (setf (label-wrap-p label) t)
1501 (container-add frame label)
1502 (box-pack-start vbox frame nil nil 0))
1504 (let ((frame (frame-new "Filled, wrapped label"))
1506 "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.
1507 This is a new paragraph.
1508 This is another newer, longer, better paragraph. It is coming to an end, unfortunately.")))
1509 (setf (label-justify label) :fill)
1510 (setf (label-wrap-p label) t)
1511 (container-add frame label)
1512 (box-pack-start vbox frame nil nil 0))
1514 (let ((frame (frame-new "Underlined label"))
1516 "This label is underlined!
1517 This one is underlined in ÆüËܸì¤ÎÆþÍÑquite a funky fashion")))
1518 (setf (label-justify label) :left)
1519 (setf (label-pattern label) "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")
1520 (container-add frame label)
1521 (box-pack-start vbox frame nil nil 0)))))
1527 (defun layout-expose-handler (layout event)
1528 (multiple-value-bind (x-offset y-offset)
1529 (layout-offset layout)
1530 (declare (fixnum x-offset y-offset))
1531 (multiple-value-bind (area-x area-y area-width area-height)
1532 (gdk:event-area event)
1533 (declare (fixnum area-x area-y area-width area-height))
1534 (let ((imin (truncate (+ x-offset area-x) 10))
1535 (imax (truncate (+ x-offset area-x area-width 9) 10))
1536 (jmin (truncate (+ y-offset area-y) 10))
1537 (jmax (truncate (+ y-offset area-y area-height 9) 10)))
1538 (declare (fixnum imin imax jmin jmax))
1539 (gdk:window-clear-area
1540 (widget-window layout) area-x area-y area-width area-height)
1542 (let ((window (layout-bin-window layout))
1543 (gc (style-get-gc (widget-style layout) :black)))
1544 (do ((i imin (1+ i)))
1546 (declare (fixnum i))
1547 (do ((j jmin (1+ j)))
1549 (declare (fixnum j))
1550 (unless (zerop (mod (+ i j) 2))
1553 (- (* 10 i) x-offset) (- (* 10 j) y-offset)
1554 (1+ (mod i 10)) (1+ (mod j 10))))))))))
1558 (define-test-window create-layout "Layout"
1559 (setf (widget-width window) 200)
1560 (setf (widget-height window) 200)
1561 (let ((scrolled (scrolled-window-new))
1562 (layout (layout-new)))
1563 (container-add window scrolled)
1564 (container-add scrolled layout)
1565 (setf (adjustment-step-increment (layout-hadjustment layout)) 10.0)
1566 (setf (adjustment-step-increment (layout-vadjustment layout)) 10.0)
1567 (setf (widget-events layout) '(:exposure))
1568 (signal-connect layout 'expose-event #'layout-expose-handler :object t)
1569 (setf (layout-size layout) '#(1600 128000))
1573 (let* ((text (format nil "Button ~D, ~D" i j))
1574 (button (if (not (zerop (mod (+ i j) 2)))
1577 (layout-put layout button (* j 100) (* i 100)))))
1581 (declare (fixnum i))
1582 (let* ((text (format nil "Button ~D, ~D" i 0))
1583 (button (if (not (zerop (mod i 2)))
1586 (layout-put layout button 0 (* i 100))))))
1592 (define-standard-dialog create-list "List"
1593 (let ((scrolled-window (scrolled-window-new))
1595 (setf (container-border-width scrolled-window) 5)
1596 (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
1597 (box-pack-start main-box scrolled-window t t 0)
1598 (setf (widget-height scrolled-window) 300)
1600 (setf (list-selection-mode list) :extended)
1601 (scrolled-window-add-with-viewport scrolled-window list)
1603 (container-focus-vadjustment list)
1604 (scrolled-window-vadjustment scrolled-window))
1606 (container-focus-hadjustment list)
1607 (scrolled-window-hadjustment scrolled-window))
1609 (with-open-file (file "cl-gtk:src;gtktypes.lisp")
1610 (labels ((read-file ()
1611 (let ((line (read-line file nil nil)))
1613 (container-add list (list-item-new line))
1617 (let ((hbox (hbox-new t 5)))
1618 (setf (container-border-width hbox) 5)
1619 (box-pack-start main-box hbox nil t 0)
1621 (let ((button (button-new "Insert Row"))
1623 (box-pack-start hbox button t t 0)
1628 (list-item-new (format nil "added item ~A" (incf i)))))
1630 (container-add list item)))))
1632 (let ((button (button-new "Clear List")))
1633 (box-pack-start hbox button t t 0)
1635 button 'clicked #'(lambda () (list-clear-items list 0 -1))))
1637 (let ((button (button-new "Remove Selection")))
1638 (box-pack-start hbox button t t 0)
1642 (let ((selection (list-selection list)))
1643 (if (eq (list-selection-mode list) :extended)
1645 (container-focus-child list)
1646 (first selection))))
1648 (let* ((children (container-children list))
1653 (eq (widget-state item) :selected))
1654 (member item children))
1657 (eq (widget-state item) :selected))
1658 (member item (reverse children))))))
1659 (list-remove-items list selection)
1661 (list-select-child list sel-row)))))
1662 (list-remove-items list selection)))))
1663 (box-pack-start hbox button t t 0)))
1665 (let ((cbox (hbox-new nil 0)))
1666 (box-pack-start main-box cbox nil t 0)
1668 (let ((hbox (hbox-new nil 5))
1672 ,#'(lambda () (setf (list-selection-mode list) :single)))
1674 ,#'(lambda () (setf (list-selection-mode list) :browse)))
1676 ,#'(lambda () (setf (list-selection-mode list) :multiple)))
1678 ,#'(lambda () (setf (list-selection-mode list) :extended))))
1681 (setf (container-border-width hbox) 5)
1682 (box-pack-start cbox hbox t nil 0)
1683 (box-pack-start hbox (label-new "Selection Mode :") nil t 0)
1684 (box-pack-start hbox option-menu nil t 0)))))
1690 (defun create-menu (depth tearoff)
1691 (unless (zerop depth)
1692 (let ((menu (menu-new)))
1694 (let ((menuitem (tearoff-menu-item-new)))
1695 (menu-append menu menuitem)
1696 (widget-show menuitem)
1701 (radio-menu-item-new
1702 group (format nil "item ~2D - ~D" depth (1+ i)))))
1703 (setq group (radio-menu-item-group menuitem)) ; ough!
1704 (unless (zerop (mod depth 2))
1705 (setf (check-menu-item-toggle-indicator-p menuitem) t))
1706 (menu-append menu menuitem)
1707 (widget-show menuitem)
1709 (setf (widget-sensitive-p menuitem) nil))
1710 (setf (menu-item-submenu menuitem) (create-menu (1- depth) t)))))
1714 (define-standard-dialog create-menus "Menus"
1715 (setf (box-spacing main-box) 0)
1716 (setf (container-border-width main-box) 0)
1717 (widget-show main-box)
1718 (let ((accel-group (accel-group-new))
1719 (menubar (menu-bar-new)))
1720 (accel-group-attach accel-group window)
1721 (box-pack-start main-box menubar nil t 0)
1722 (widget-show menubar)
1724 (let ((menuitem (menu-item-new (format nil "test~%line2"))))
1725 (setf (menu-item-submenu menuitem) (create-menu 2 t))
1726 (menu-bar-append menubar menuitem)
1727 (widget-show menuitem))
1729 (let ((menuitem (menu-item-new "foo")))
1730 (setf (menu-item-submenu menuitem) (create-menu 3 t))
1731 (menu-bar-append menubar menuitem)
1732 (widget-show menuitem))
1734 (let ((menuitem (menu-item-new "bar")))
1735 (setf (menu-item-submenu menuitem) (create-menu 4 t))
1736 (menu-item-right-justify menuitem)
1737 (menu-bar-append menubar menuitem)
1738 (widget-show menuitem))
1740 (let ((box2 (vbox-new nil 10))
1741 (menu (create-menu 1 nil)))
1742 (setf (container-border-width box2) 10)
1743 (box-pack-start main-box box2 t t 0)
1746 (setf (menu-accel-group menu) accel-group)
1748 (let ((menuitem (check-menu-item-new "Accelerate Me")))
1749 (menu-append menu menuitem)
1750 (widget-show menuitem)
1751 (widget-add-accelerator
1752 menuitem 'activate accel-group "F1" 0 '(:visible :signal-visible)))
1754 (let ((menuitem (check-menu-item-new "Accelerator Locked")))
1755 (menu-append menu menuitem)
1756 (widget-show menuitem)
1757 (widget-add-accelerator
1758 menuitem 'activate accel-group "F2" 0 '(:visible :locked)))
1760 (let ((menuitem (check-menu-item-new "Accelerator Frozen")))
1761 (menu-append menu menuitem)
1762 (widget-show menuitem)
1763 (widget-add-accelerator
1764 menuitem 'activate accel-group "F2" 0 '(:visible))
1765 (widget-add-accelerator
1766 menuitem 'activate accel-group "F3" 0 '(:visible))
1767 (widget-lock-accelerators menuitem))
1769 (let ((optionmenu (option-menu-new)))
1770 (setf (option-menu-menu optionmenu) menu)
1771 (setf (option-menu-history optionmenu) 3)
1772 (box-pack-start box2 optionmenu t t 0)
1773 (widget-show optionmenu)))))
1778 (define-standard-dialog create-notebook "Notebook"
1779 (multiple-value-bind (book-open book-open-mask)
1780 (gdk:pixmap-create book-open-xpm)
1781 (multiple-value-bind (book-closed book-closed-mask)
1782 (gdk:pixmap-create book-closed-xpm)
1785 ((create-pages (notebook i end)
1787 (let* ((title (format nil "Page ~D" i))
1788 (child (frame-new title))
1789 (vbox (vbox-new t 0))
1790 (hbox (hbox-new t 0)))
1791 (setf (container-border-width child) 10)
1792 (setf (container-border-width vbox) 10)
1793 (container-add child vbox)
1794 (box-pack-start vbox hbox nil t 5)
1796 (let ((button (check-button-new "Fill Tab")))
1797 (box-pack-start hbox button t t 5)
1798 (setf (toggle-button-active-p button) t)
1802 (multiple-value-bind (expand fill pack-type)
1803 (notebook-query-tab-label-packing notebook child)
1804 (declare (ignore fill))
1805 (notebook-set-tab-label-packing
1806 notebook child expand
1807 (toggle-button-active-p button) pack-type)))))
1809 (let ((button (check-button-new "Expand Tab")))
1810 (box-pack-start hbox button t t 5)
1814 (multiple-value-bind (expand fill pack-type)
1815 (notebook-query-tab-label-packing notebook child)
1816 (declare (ignore expand))
1817 (notebook-set-tab-label-packing
1818 notebook child (toggle-button-active-p button)
1821 (let ((button (check-button-new "Pack end")))
1822 (box-pack-start hbox button t t 5)
1826 (multiple-value-bind (expand fill pack-type)
1827 (notebook-query-tab-label-packing notebook child)
1828 (declare (ignore pack-type))
1829 (notebook-set-tab-label-packing
1830 notebook child expand fill
1831 (if (toggle-button-active-p button)
1835 (let ((button (button-new "Hide Page")))
1836 (box-pack-start vbox button nil nil 5)
1838 button 'clicked #'(lambda () (widget-hide child))))
1840 (widget-show-all child)
1842 (let ((label-box (hbox-new nil 0))
1843 (menu-box (hbox-new nil 0)))
1845 label-box (pixmap-new (list book-closed book-closed-mask))
1847 (box-pack-start label-box (label-new title) nil t 0)
1848 (widget-show-all label-box)
1850 menu-box (pixmap-new (list book-closed book-closed-mask))
1852 (box-pack-start menu-box (label-new title) nil t 0)
1853 (widget-show-all menu-box)
1854 (notebook-append-page notebook child label-box menu-box)))
1856 (create-pages notebook (1+ i) end))))
1859 (setf (container-border-width main-box) 0)
1860 (setf (box-spacing main-box) 0)
1862 (let ((notebook (notebook-new)))
1864 notebook 'switch-page
1865 #'(lambda (pointer page)
1866 (declare (ignore pointer))
1867 (let ((old-page (notebook-current-page-num notebook)))
1868 (unless (eq page old-page)
1873 (notebook-tab-label notebook page))))
1874 (list book-open book-open-mask))
1879 (notebook-menu-label notebook page))))
1880 (list book-open book-open-mask))
1887 (notebook-tab-label notebook old-page))))
1888 (list book-closed book-closed-mask))
1893 (notebook-menu-label notebook old-page))))
1894 (list book-closed book-closed-mask)))))))
1896 (setf (notebook-tab-pos notebook) :top)
1897 (box-pack-start main-box notebook t t 0)
1898 (setf (container-border-width notebook) 10)
1900 (widget-realize notebook)
1901 (create-pages notebook 1 5)
1903 (box-pack-start main-box (hseparator-new) nil t 10)
1905 (let ((box2 (hbox-new nil 5)))
1906 (setf (container-border-width box2) 10)
1907 (box-pack-start main-box box2 nil t 0)
1909 (let ((button (check-button-new "popup menu")))
1910 (box-pack-start box2 button t nil 0)
1914 (if (toggle-button-active-p button)
1915 (notebook-popup-enable notebook)
1916 (notebook-popup-disable notebook)))))
1918 (let ((button (check-button-new "homogeneous tabs")))
1919 (box-pack-start box2 button t nil 0)
1924 (notebook-homogeneous-p notebook)
1925 (toggle-button-active-p button))))))
1927 (let ((box2 (hbox-new nil 5)))
1928 (setf (container-border-width box2) 10)
1929 (box-pack-start main-box box2 nil t 0)
1931 (box-pack-start box2 (label-new "Notebook Style : ") nil t 0)
1933 (let* ((scrollable-p nil)
1938 (setf (notebook-show-tabs-p notebook) t)
1940 (setq scrollable-p nil)
1941 (setf (notebook-scrollable-p notebook) nil)
1943 (notebook-remove-page notebook 5)))))
1946 (setf (notebook-show-tabs-p notebook) nil)
1948 (setq scrollable-p nil)
1949 (setf (notebook-scrollable-p notebook) nil)
1951 (notebook-remove-page notebook 5)))))
1954 (unless scrollable-p
1955 (setq scrollable-p t)
1956 (setf (notebook-show-tabs-p notebook) t)
1957 (setf (notebook-scrollable-p notebook) t)
1958 (create-pages notebook 6 15)))))
1960 (box-pack-start box2 option-menu nil t 0))
1962 (let ((button (button-new "Show all Pages")))
1963 (box-pack-start box2 button nil t 0)
1967 (container-foreach notebook #'widget-show)))))
1969 (let ((box2 (hbox-new nil 5)))
1970 (setf (container-border-width box2) 10)
1971 (box-pack-start main-box box2 nil t 0)
1973 (let ((button (button-new "prev")))
1974 (box-pack-start box2 button t t 0)
1978 (notebook-prev-page notebook))))
1980 (let ((button (button-new "next")))
1981 (box-pack-start box2 button t t 0)
1985 (notebook-next-page notebook))))
1987 (let ((button (button-new "rotate"))
1989 (box-pack-start box2 button t t 0)
1993 (setq tab-pos (mod (1+ tab-pos) 4))
1994 (setf (notebook-tab-pos notebook) tab-pos))))))))))
2000 (defun toggle-resize (child)
2001 (let* ((paned (widget-parent child))
2002 (is-child1-p (eq child (paned-child1 paned))))
2003 (multiple-value-bind (child resize shrink)
2005 (paned-child1 paned)
2006 (paned-child2 paned))
2008 (container-remove paned child)
2010 (paned-pack1 paned child (not resize) shrink)
2011 (paned-pack2 paned child (not resize) shrink))
2012 (widget-unref child))))
2014 (defun toggle-shrink (child)
2015 (let* ((paned (widget-parent child))
2016 (is-child1-p (eq child (paned-child1 paned))))
2017 (multiple-value-bind (child resize shrink)
2019 (paned-child1 paned)
2020 (paned-child2 paned))
2022 (container-remove paned child)
2024 (paned-pack1 paned child resize (not shrink))
2025 (paned-pack2 paned child resize (not shrink)))
2026 (widget-unref child))))
2028 (defun create-pane-options (paned frame-label label1 label2)
2029 (let ((frame (frame-new frame-label))
2030 (table (table-new 3 2 t)))
2031 (setf (container-border-width frame) 4)
2032 (container-add frame table)
2034 (table-attach table (label-new label1) 0 1 0 1)
2036 (let ((check-button (check-button-new "Resize")))
2037 (table-attach table check-button 0 1 1 2)
2039 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
2041 (let ((check-button (check-button-new "Shrink")))
2042 (table-attach table check-button 0 1 2 3)
2043 (setf (toggle-button-active-p check-button) t)
2045 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
2047 (table-attach table (label-new label2) 1 2 0 1)
2049 (let ((check-button (check-button-new "Resize")))
2050 (table-attach table check-button 1 2 1 2)
2051 (setf (toggle-button-active-p check-button) t)
2053 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
2055 (let ((check-button (check-button-new "Shrink")))
2056 (table-attach table check-button 1 2 2 3)
2057 (setf (toggle-button-active-p check-button) t)
2059 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
2063 (define-test-window create-panes "Panes"
2064 (let ((vbox (vbox-new nil 0))
2065 (vpaned (vpaned-new))
2066 (hpaned (hpaned-new)))
2067 (container-add window vbox)
2068 (box-pack-start vbox vpaned t t 0)
2069 (setf (container-border-width vpaned) 5)
2071 (paned-add1 vpaned hpaned)
2073 (let ((frame (frame-new nil)))
2074 (setf (frame-shadow-type frame) :in)
2075 (setf (widget-width frame) 60)
2076 (setf (widget-height frame) 60)
2077 (paned-add1 hpaned frame)
2078 (container-add frame (button-new "Hi there")))
2080 (let ((frame (frame-new nil)))
2081 (setf (frame-shadow-type frame) :in)
2082 (setf (widget-width frame) 80)
2083 (setf (widget-height frame) 60)
2084 (paned-add2 hpaned frame))
2086 (let ((frame (frame-new nil)))
2087 (setf (frame-shadow-type frame) :in)
2088 (setf (widget-width frame) 80)
2089 (setf (widget-height frame) 60)
2090 (paned-add2 vpaned frame))
2092 ;; Now create toggle buttons to control sizing
2095 vbox (create-pane-options hpaned "Horizontal" "Left" "Right") nil nil 0)
2098 vbox (create-pane-options vpaned "Vertical" "Top" "Bottom") nil nil 0)))
2104 (define-standard-dialog create-pixmap "Pixmap"
2105 (setf (container-border-width main-box) 10)
2106 (let* ((button (button-new))
2107 (hbox (hbox-new nil 0)))
2108 (box-pack-start main-box button nil nil 0)
2109 (container-add button hbox)
2110 (setf (container-border-width hbox) 2)
2111 (container-add hbox (pixmap-new "cl-gtk:src;test.xpm"))
2112 (container-add hbox (label-new "Pixmap test"))))
2118 (define-standard-dialog create-progress-bar "Progress bar"
2119 (setf (window-allow-grow-p window) nil)
2120 (setf (window-allow-shrink-p window) nil)
2121 (setf (window-auto-shrink-p window) t)
2123 (setf (container-border-width main-box) 10)
2125 (let* ((pbar-adj (adjustment-new 0 1 300 0 0 0))
2126 (pbar (progress-bar-new pbar-adj))
2127 (user-label (label-new "")))
2129 (let ((frame (frame-new "Progress"))
2130 (vbox (vbox-new nil 5)))
2131 (box-pack-start main-box frame nil t 0)
2132 (container-add frame vbox)
2134 (let ((timer (timeout-add
2137 (let* ((value (adjustment-value pbar-adj))
2139 (if (= value (adjustment-upper pbar-adj))
2140 (adjustment-lower pbar-adj)
2142 (setf (progress-value pbar) new-value))
2144 (signal-connect window 'destroy #'(lambda () (timeout-remove timer))))
2147 pbar-adj 'value-changed
2150 (label-text user-label)
2151 (if (progress-activity-mode-p pbar)
2153 (format nil "~D" (round (* 100 (progress-percentage pbar))))))))
2155 (setf (progress-format-string pbar) "%v from [%l,%u] (=%p%%)")
2157 (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
2158 (box-pack-start vbox align nil nil 0)
2159 (container-add align pbar))
2161 (let ((hbox (hbox-new nil 5)))
2162 (box-pack-start hbox (label-new "Label updated by user :") nil t 0)
2163 (box-pack-start hbox user-label nil t 0)
2165 (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
2166 (box-pack-start vbox align nil nil 5)
2167 (container-add align hbox))))
2169 (let ((frame (frame-new "Options"))
2170 (vbox (vbox-new nil 5)))
2171 (box-pack-start main-box frame nil t 0)
2172 (container-add frame vbox)
2174 (let ((table (table-new 7 2 nil)))
2175 (box-pack-start vbox table nil t 0)
2177 (let ((label (label-new "Orientation :")))
2178 (setf (misc-xalign label) 0.0)
2179 (setf (misc-yalign label) 0.5)
2180 (table-attach table label 0 1 0 1 :x-padding 5 :y-padding 5))
2182 (let ((hbox (hbox-new nil 0)))
2188 (setf (progress-bar-orientation pbar) :left-to-right)))
2191 (setf (progress-bar-orientation pbar) :right-to-left)))
2194 (setf (progress-bar-orientation pbar) :bottom-to-top)))
2197 (setf (progress-bar-orientation pbar) :top-to-bottom))))
2200 (table-attach table hbox 1 2 0 1 :x-padding 5 :y-padding 5))
2202 (let* ((button (check-button-new "Show text"))
2204 (x-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
2205 (x-align-spin (spin-button-new x-align-adj 0 1))
2206 (y-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
2207 (y-align-spin (spin-button-new y-align-adj 0 1)))
2212 (let ((state (toggle-button-active-p button)))
2213 (setf (progress-show-text-p pbar) state)
2214 (setf (widget-sensitive-p entry) state)
2215 (setf (widget-sensitive-p x-align-spin) state)
2216 (setf (widget-sensitive-p y-align-spin) state))))
2217 (table-attach table button 0 1 1 2 :x-padding 5 :y-padding 5)
2223 (progress-format-string pbar)
2224 (entry-text entry))))
2225 (setf (entry-text entry) "%v from [%l,%u] (=%p%%)")
2226 (setf (widget-width entry) 100)
2227 (setf (widget-sensitive-p entry) nil)
2229 (let ((hbox (hbox-new nil 0)))
2230 (box-pack-start hbox (label-new "Format : ") nil t 0)
2231 (box-pack-start hbox entry t t 0)
2232 (table-attach table hbox 1 2 1 2 :x-padding 5 :y-padding 5))
2234 (let ((label (label-new "Text align :")))
2235 (setf (misc-xalign label) 0.0)
2236 (setf (misc-yalign label) 0.5)
2237 (table-attach table label 0 1 2 3 :x-padding 5 :y-padding 5))
2239 (flet ((adjust-align ()
2241 (progress-text-xalign pbar)
2242 (spin-button-value x-align-spin))
2244 (progress-text-yalign pbar)
2245 (spin-button-value y-align-spin))))
2246 (signal-connect x-align-adj 'value-changed #'adjust-align)
2247 (signal-connect y-align-adj 'value-changed #'adjust-align))
2248 (setf (widget-sensitive-p x-align-spin) nil)
2249 (setf (widget-sensitive-p y-align-spin) nil)
2251 (let ((hbox (hbox-new nil 0)))
2252 (box-pack-start hbox (label-new "x :") nil t 5)
2253 (box-pack-start hbox x-align-spin nil t 0)
2254 (box-pack-start hbox (label-new "y :") nil t 5)
2255 (box-pack-start hbox y-align-spin nil t 0)
2256 (table-attach table hbox 1 2 2 3 :x-padding 5 :y-padding 5)))
2258 (let ((label (label-new "Bar Style :")))
2259 (setf (misc-xalign label) 0.0)
2260 (setf (misc-yalign label) 0.5)
2261 (table-attach table label 0 1 3 4 :x-padding 5 :y-padding 5))
2263 (let* ((block-adj (adjustment-new 10 2 20 1 5 0))
2264 (block-spin (spin-button-new block-adj 0 0)))
2265 (let ((hbox (hbox-new nil 0)))
2271 (setf (progress-bar-style pbar) :continuous)
2272 (setf (widget-sensitive-p block-spin) nil)))
2275 (setf (progress-bar-style pbar) :discrete)
2276 (setf (widget-sensitive-p block-spin) t))))
2279 (table-attach table hbox 1 2 3 4 :x-padding 5 :y-padding 5))
2281 (let ((label (label-new "Block count :")))
2282 (setf (misc-xalign label) 0.0)
2283 (setf (misc-yalign label) 0.5)
2284 (table-attach table label 0 1 4 5 :x-padding 5 :y-padding 5))
2287 block-adj 'value-changed
2289 (setf (progress-percentage pbar) 0)
2291 (progress-bar-discrete-blocks pbar)
2292 (spin-button-value-as-int block-spin))))
2293 (setf (widget-sensitive-p block-spin) nil)
2295 (let ((hbox (hbox-new nil 0)))
2296 (box-pack-start hbox block-spin nil t 0)
2297 (table-attach table hbox 1 2 4 5 :x-padding 5 :y-padding 5)))
2299 (let* ((step-size-adj (adjustment-new 3 1 20 1 5 0))
2300 (step-size-spin (spin-button-new step-size-adj 0 0))
2301 (block-adj (adjustment-new 5 2 10 1 5 00))
2302 (block-spin (spin-button-new block-adj 0 0)))
2304 (let ((button (check-button-new "Activity mode")))
2308 (let ((state (toggle-button-active-p button)))
2309 (setf (progress-activity-mode-p pbar) state)
2310 (setf (widget-sensitive-p step-size-spin) state)
2311 (setf (widget-sensitive-p block-spin) state))))
2312 (table-attach table button 0 1 5 6 :x-padding 5 :y-padding 5))
2315 step-size-adj 'value-changed
2318 (progress-bar-activity-step pbar)
2319 (spin-button-value-as-int step-size-spin))))
2320 (setf (widget-sensitive-p step-size-spin) nil)
2322 (let ((hbox (hbox-new nil 0)))
2323 (box-pack-start hbox (label-new "Step size : ") nil t 0)
2324 (box-pack-start hbox step-size-spin nil t 0)
2325 (table-attach table hbox 1 2 5 6 :x-padding 5 :y-padding 5))
2328 block-adj 'value-changed
2331 (progress-bar-activity-blocks pbar)
2332 (spin-button-value-as-int block-spin))))
2333 (setf (widget-sensitive-p block-spin) nil)
2335 (let ((hbox (hbox-new nil 0)))
2336 (box-pack-start hbox (label-new "Blocks : ") nil t 0)
2337 (box-pack-start hbox block-spin nil t 0)
2338 (table-attach table hbox 1 2 6 7 :x-padding 5 :y-padding 5)))))))
2344 (define-standard-dialog create-radio-buttons "Radio buttons"
2345 (setf (container-border-width main-box) 10)
2346 (setf (box-spacing main-box) 10)
2347 (let* ((button1 (radio-button-new nil :label "button1"))
2348 (button2 (radio-button-new
2349 (radio-button-group button1) :label "button2"))
2350 (button3 (radio-button-new
2351 (radio-button-group button2) :label "button3")))
2352 (box-pack-start main-box button1 t t 0)
2353 (box-pack-start main-box button2 t t 0)
2354 (setf (toggle-button-active-p button2) t)
2355 (box-pack-start main-box button3 t t 0)))
2361 (define-standard-dialog create-range-controls "Range controls"
2362 (setf (container-border-width main-box) 10)
2363 (setf (box-spacing main-box) 10)
2364 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
2366 (let ((scale (hscale-new adjustment)))
2367 (setf (widget-width scale) 150)
2368 (setf (widget-height scale) 30)
2369 (setf (range-update-policy scale) :delayed)
2370 (setf (scale-digits scale) 1)
2371 (setf (scale-draw-value-p scale) t)
2372 (box-pack-start main-box scale t t 0))
2374 (let ((scrollbar (hscrollbar-new adjustment)))
2375 (setf (range-update-policy scrollbar) :continuous)
2376 (box-pack-start main-box scrollbar t t 0))))
2382 (define-standard-dialog create-reparent "reparent"
2383 (let ((box2 (hbox-new nil 5))
2384 (label (label-new "Hellow World")))
2385 (setf (container-border-width box2) 10)
2386 (box-pack-start main-box box2 t t 0)
2388 (let ((frame (frame-new "Frame 1"))
2389 (box3 (vbox-new nil 5))
2390 (button (button-new "switch")))
2391 (box-pack-start box2 frame t t 0)
2393 (setf (container-border-width box3) 5)
2394 (container-add frame box3)
2399 (widget-reparent label box3)))
2400 (box-pack-start box3 button nil t 0)
2402 (box-pack-start box3 label nil t 0)
2405 #'(lambda (old-parent)
2406 (declare (ignore old-parent)))))
2408 (let ((frame (frame-new "Frame 2"))
2409 (box3 (vbox-new nil 5))
2410 (button (button-new "switch")))
2411 (box-pack-start box2 frame t t 0)
2413 (setf (container-border-width box3) 5)
2414 (container-add frame box3)
2419 (widget-reparent label box3)))
2420 (box-pack-start box3 button nil t 0))))
2426 (define-test-window create-rulers "rulers"
2427 (setf (widget-width window) 300)
2428 (setf (widget-height window) 300)
2429 (setf (widget-events window) '(:pointer-motion :pointer-motion-hint))
2431 (let ((table (table-new 2 2 nil)))
2432 (container-add window table)
2435 (let ((ruler (hruler-new)))
2436 (setf (ruler-metric ruler) :centimeters)
2437 (ruler-set-range ruler 100 0 0 20)
2439 window 'motion-notify-event
2440 #'(lambda (event) (widget-event ruler event)))
2441 (table-attach table ruler 1 2 0 1 :y-options '(:fill))
2442 (widget-show ruler))
2444 (let ((ruler (vruler-new)))
2445 (ruler-set-range ruler 5 15 0 20)
2447 window 'motion-notify-event
2448 #'(lambda (event) (widget-event ruler event)))
2449 (table-attach table ruler 0 1 1 2 :x-options '(:fill))
2450 (widget-show ruler))))
2456 (define-standard-dialog create-scrolled-windows "Scrolled windows"
2457 (let ((scrolled-window (scrolled-window-new nil nil)))
2458 (setf (container-border-width scrolled-window) 10)
2459 (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
2460 (box-pack-start main-box scrolled-window t t 0)
2462 (let ((table (table-new 20 20 nil)))
2463 (setf (table-row-spacings table) 10)
2464 (setf (table-column-spacings table) 10)
2465 (scrolled-window-add-with-viewport scrolled-window table)
2467 (container-focus-vadjustment table)
2468 (scrolled-window-vadjustment scrolled-window))
2470 (container-focus-hadjustment table)
2471 (scrolled-window-hadjustment scrolled-window))
2476 (toggle-button-new (format nil "button (~D,~D)~%" i j))))
2477 (table-attach table button i (1+ i) j (1+ j)))))))
2479 (let ((button (button-new "remove")))
2480 (signal-connect button 'clicked #'(lambda ()))
2481 (setf (widget-can-default-p button) t)
2482 (box-pack-start action-area button t t 0)
2483 (widget-grab-default button))
2485 (setf (window-default-height window) 300)
2486 (setf (window-default-width window) 300))
2492 (defun shape-create-icon (xpm-file x y px py window-type root-window)
2493 (let ((window (window-new window-type))
2494 (fixed (fixed-new)))
2495 (setf (widget-width fixed) 100)
2496 (setf (widget-height fixed) 100)
2497 (container-add window fixed)
2501 (widget-events window)
2503 (widget-events window)
2504 '(:button-motion :pointer-motion-hint :button-press)))
2505 (widget-realize window)
2507 (multiple-value-bind (gdk-pixmap gdk-pixmap-mask)
2508 (gdk:pixmap-create xpm-file)
2509 (let ((pixmap (pixmap-new (list gdk-pixmap gdk-pixmap-mask)))
2512 (declare (fixnum x-offset y-offset))
2513 (fixed-put fixed pixmap px py)
2514 (widget-show pixmap)
2515 (widget-shape-combine-mask window gdk-pixmap-mask px py)
2517 window 'button-press-event
2519 (when (eq (gdk:event-type event) :button-press)
2520 (setq x-offset (truncate (gdk:event-x event)))
2521 (setq y-offset (truncate (gdk:event-y event)))
2524 (widget-window window) t
2525 '(:button-release :button-motion :pointer-motion-hint)
2530 window 'button-release-event
2532 (declare (ignore event))
2533 (grab-remove window)
2534 (gdk:pointer-ungrab 0)
2538 window 'motion-notify-event
2540 (declare (ignore event))
2541 (multiple-value-bind (win xp yp mask)
2542 (gdk:window-get-pointer root-window)
2543 (declare (ignore mask win) (fixnum xp yp))
2544 (widget-set-uposition
2545 window :x (- xp x-offset) :y (- yp y-offset)))
2548 (widget-set-uposition window :x x :y y)
2549 (widget-show window)
2553 (let ((modeller nil)
2556 (defun create-shapes ()
2557 (let ((root-window (gdk:get-root-window)))
2563 "cl-gtk:src;Modeller.xpm"
2564 440 140 0 0 :popup root-window))
2567 #'(lambda () (widget-destroyed modeller))))
2568 (widget-destroy modeller))
2575 "cl-gtk:src;FilesQueue.xpm"
2576 580 170 0 0 :popup root-window))
2579 #'(lambda () (widget-destroyed sheets))))
2580 (widget-destroy sheets))
2587 "cl-gtk:src;3DRings.xpm"
2588 460 270 25 25 :toplevel root-window))
2591 #'(lambda () (widget-destroyed rings))))
2592 (widget-destroy rings)))))
2598 (define-test-window create-spins "Spin buttons"
2599 (let ((main-vbox (vbox-new nil 5)))
2600 (setf (container-border-width main-vbox) 10)
2601 (container-add window main-vbox)
2603 (let ((frame (frame-new "Not accelerated"))
2604 (vbox (vbox-new nil 0))
2605 (hbox (hbox-new nil 0)))
2606 (box-pack-start main-vbox frame t t 0)
2607 (setf (container-border-width vbox) 5)
2608 (container-add frame vbox)
2609 (box-pack-start vbox hbox t t 5)
2611 (let* ((vbox2 (vbox-new nil 0))
2612 (label (label-new "Day :"))
2613 (spinner (spin-button-new
2614 (adjustment-new 1 1 31 1 5 0) 0 0)))
2615 (box-pack-start hbox vbox2 t t 5)
2616 (setf (misc-xalign label) 0)
2617 (setf (misc-yalign label) 0.5)
2618 (box-pack-start vbox2 label nil t 0)
2619 (setf (spin-button-wrap-p spinner) t)
2620 (setf (spin-button-shadow-type spinner) :out)
2621 (box-pack-start vbox2 spinner nil t 0))
2623 (let* ((vbox2 (vbox-new nil 0))
2624 (label (label-new "Month :"))
2625 (spinner (spin-button-new
2626 (adjustment-new 1 1 12 1 5 0) 0 0)))
2627 (box-pack-start hbox vbox2 t t 5)
2628 (setf (misc-xalign label) 0)
2629 (setf (misc-yalign label) 0.5)
2630 (box-pack-start vbox2 label nil t 0)
2631 (setf (spin-button-wrap-p spinner) t)
2632 (setf (spin-button-shadow-type spinner) :etched-in)
2633 (box-pack-start vbox2 spinner nil t 0))
2635 (let* ((vbox2 (vbox-new nil 0))
2636 (label (label-new "Year :"))
2637 (spinner (spin-button-new
2638 (adjustment-new 1998 0 2100 1 100 0) 0 0)))
2639 (box-pack-start hbox vbox2 t t 5)
2640 (setf (misc-xalign label) 0)
2641 (setf (misc-yalign label) 0.5)
2642 (box-pack-start vbox2 label nil t 0)
2643 (setf (spin-button-wrap-p spinner) t)
2644 (setf (spin-button-shadow-type spinner) :in)
2645 (box-pack-start vbox2 spinner nil t 0)))
2647 (let* ((frame (frame-new "Accelerated"))
2648 (vbox (vbox-new nil 0))
2649 (hbox (hbox-new nil 0))
2650 (spinner1 (spin-button-new
2651 (adjustment-new 0 -10000 10000 0.5 100 0) 1.0 2))
2652 (adj (adjustment-new 2 1 5 1 1 0))
2653 (spinner2 (spin-button-new adj 1.0 0)))
2655 (box-pack-start main-vbox frame t t 0)
2656 (setf (container-border-width vbox) 5)
2657 (container-add frame vbox)
2658 (box-pack-start vbox hbox nil t 5)
2660 (let* ((vbox2 (vbox-new nil 0))
2661 (label (label-new "Value :")))
2662 (box-pack-start hbox vbox2 t t 5)
2663 (setf (misc-xalign label) 0)
2664 (setf (misc-yalign label) 0.5)
2665 (box-pack-start vbox2 label nil t 0)
2666 (setf (spin-button-wrap-p spinner1) t)
2667 (setf (widget-width spinner1) 100)
2668 (setf (widget-height spinner1) 0)
2669 (box-pack-start vbox2 spinner1 nil t 0))
2671 (let* ((vbox2 (vbox-new nil 0))
2672 (label (label-new "Digits :")))
2673 (box-pack-start hbox vbox2 t t 5)
2674 (setf (misc-xalign label) 0)
2675 (setf (misc-yalign label) 0.5)
2676 (box-pack-start vbox2 label nil t 0)
2677 (setf (spin-button-wrap-p spinner2) t)
2678 (signal-connect adj 'value-changed
2681 (spin-button-digits spinner1)
2682 (floor (spin-button-value spinner2)))))
2683 (box-pack-start vbox2 spinner2 nil t 0))
2685 (let ((button (check-button-new "Snap to 0.5-ticks")))
2686 (signal-connect button 'clicked
2689 (spin-button-snap-to-ticks-p spinner1)
2690 (toggle-button-active-p button))))
2691 (box-pack-start vbox button t t 0)
2692 (setf (toggle-button-active-p button) t))
2694 (let ((button (check-button-new "Numeric only input mode")))
2695 (signal-connect button 'clicked
2698 (spin-button-numeric-p spinner1)
2699 (toggle-button-active-p button))))
2700 (box-pack-start vbox button t t 0)
2701 (setf (toggle-button-active-p button) t))
2703 (let ((val-label (label-new "0"))
2704 (hbox (hbox-new nil 0)))
2705 (box-pack-start vbox hbox nil t 5)
2706 (let ((button (button-new "Value as Int")))
2711 (label-text val-label)
2712 (format nil "~D" (spin-button-value-as-int spinner1)))))
2713 (box-pack-start hbox button t t 5))
2715 (let ((button (button-new "Value as Float")))
2720 (label-text val-label)
2722 (format nil "~~,~DF" (spin-button-digits spinner1))
2723 (spin-button-value spinner1)))))
2724 (box-pack-start hbox button t t 5))
2726 (box-pack-start vbox val-label t t 0)))
2728 (let ((hbox (hbox-new nil 0))
2729 (button (button-new "Close")))
2730 (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
2731 (box-pack-start main-vbox hbox nil t 0)
2732 (box-pack-start hbox button t t 5))))
2738 (define-test-window create-statusbar "Statusbar"
2739 (let ((box1 (vbox-new nil 0)))
2740 (container-add window box1)
2742 (let ((box2 (vbox-new nil 10))
2743 (statusbar (statusbar-new))
2744 (statusbar-counter 0))
2745 (setf (container-border-width box2) 10)
2746 (box-pack-start box1 box2 t t 0)
2747 (box-pack-end box1 statusbar t t 0)
2749 statusbar 'text-popped
2750 #'(lambda (context-id text)
2751 (declare (ignore context-id))
2752 (format nil "Popped: ~A~%" text)))
2755 :label "push something"
2764 (format nil "something ~D" (incf statusbar-counter))))))
2773 (statusbar-pop statusbar 1))
2783 (statusbar-remove statusbar 1 4))
2786 (make-button :label "test contexts"
2789 :signal (list 'clicked #'(lambda ()))))
2791 (box-pack-start box1 (hseparator-new) nil t 0)
2793 (let ((box2 (vbox-new nil 10)))
2794 (setf (container-border-width box2) 10)
2795 (box-pack-start box1 box2 nil t 0)
2797 (let ((button (button-new "close")))
2798 (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
2799 (box-pack-start box2 button t t 0)
2800 (setf (widget-can-default-p button) t)
2801 (widget-grab-default button)))))
2807 (define-standard-dialog create-idle-test "Idle Test"
2808 (let ((label (label-new "count: 0"))
2811 (declare (fixnum count))
2813 window 'destroy #'(lambda () (when idle (idle-remove idle))))
2815 (setf (misc-xpad label) 10)
2816 (setf (misc-ypad label) 10)
2817 (box-pack-start main-box label t t 0)
2819 (let* ((container (make-hbox :parent main-box :child label :visible t))
2822 :label "Label Container"
2825 (box (make-vbox :visible t :parent frame)))
2827 :label "Resize-Parent"
2834 (setf (container-resize-mode container) :parent))))
2837 :label "Resize-Queue"
2844 (setf (container-resize-mode container) :queue))))
2847 :label "Resize-Immediate"
2854 (setf (container-resize-mode container) :immediate)))))
2856 (let ((button (button-new "start")))
2866 (setf (label-text label) (format nil "count: ~D" count))
2868 (setf (widget-can-default-p button) t)
2869 (box-pack-start action-area button t t 0)
2870 (widget-show button))
2872 (let ((button (button-new "stop")))
2879 (setf (widget-can-default-p button) t)
2880 (box-pack-start action-area button t t 0)
2881 (widget-show button))))
2887 (define-standard-dialog create-timeout-test "Timeout Test"
2888 (let ((label (label-new "count: 0"))
2891 (declare (fixnum count))
2893 window 'destroy #'(lambda () (when timer (timeout-remove timer))))
2895 (setf (misc-xpad label) 10)
2896 (setf (misc-ypad label) 10)
2897 (box-pack-start main-box label t t 0)
2900 (let ((button (button-new "start")))
2911 (setf (label-text label) (format nil "count: ~D" count))
2913 (setf (widget-can-default-p button) t)
2914 (box-pack-start action-area button t t 0)
2915 (widget-show button))
2917 (let ((button (button-new "stop")))
2922 (timeout-remove timer)
2924 (setf (widget-can-default-p button) t)
2925 (box-pack-start action-area button t t 0)
2926 (widget-show button))))
2932 (define-test-window create-text "Text"
2933 (setf (widget-name window) "text window")
2934 (setf (widget-width window) 500)
2935 (setf (widget-height window) 500)
2936 (setf (window-allow-grow-p window) t)
2937 (setf (window-allow-shrink-p window) t)
2938 (setf (window-auto-shrink-p window) nil)
2939 (let ((box1 (vbox-new nil 0)))
2940 (container-add window box1)
2942 (let ((box2 (vbox-new nil 10)))
2943 (setf (container-border-width box2) 10)
2944 (box-pack-start box1 box2 t t 0)
2946 (let ((scrolled-window (scrolled-window-new))
2948 (box-pack-start box2 scrolled-window t t 0)
2949 (setf (scrolled-window-hscrollbar-policy scrolled-window) :never)
2950 (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
2951 (setf (editable-editable-p text) t)
2952 (container-add scrolled-window text)
2953 (widget-grab-focus text)
2958 "-adobe-courier-medium-r-normal--*-120-*-*-*-*-*-*"))
2961 #'(lambda (definition)
2963 (gdk:color-new-from-vector (first definition))
2964 (second definition)))
2965 '((#(#x0000 #x0000 #x0000) "black")
2966 (#(#xFFFF #xFFFF #xFFFF) "white")
2967 (#(#xFFFF #x0000 #x0000) "red")
2968 (#(#x0000 #xFFFF #x0000) "green")
2969 (#(#x0000 #x0000 #xFFFF) "blue")
2970 (#(#x0000 #xFFFF #xFFFF) "cyan")
2971 (#(#xFFFF #x0000 #xFFFF) "magneta")
2972 (#(#xFFFF #xFFFF #x0000) "yellow")))))
2973 (dolist (color1 colors)
2974 (text-insert text (format nil "~A~,7T" (cdr color1)) :font font)
2975 (dolist (color2 colors)
2977 text "XYZ" :font font
2978 :foreground (car color2) :background (car color1)))
2979 (text-insert text (format nil "~%")))
2980 (dolist (color colors)
2981 (gdk:color-destroy (car color)))
2982 (gdk:font-unref font))
2984 (with-open-file (file "cl-gtk:src;testgtk.lisp")
2985 (labels ((read-file ()
2986 (let ((line (read-line file nil nil)))
2988 (text-insert text (format nil "~A~%" line))
2994 (let ((hbox (hbutton-box-new)))
2995 (box-pack-start box2 hbox nil nil 0)
2996 (let ((check-button (check-button-new "Editable")))
2997 (box-pack-start hbox check-button nil nil 0)
2999 check-button 'toggled
3002 (editable-editable-p text)
3003 (toggle-button-active-p check-button))))
3004 (setf (toggle-button-active-p check-button) t))
3006 (let ((check-button (check-button-new "Wrap Words")))
3007 (box-pack-start hbox check-button nil t 0)
3009 check-button 'toggled
3012 (text-word-wrap-p text)
3013 (toggle-button-active-p check-button))))
3014 (setf (toggle-button-active-p check-button) nil)))))
3016 (box-pack-start box1 (hseparator-new) nil t 0)
3018 (let ((box2 (vbox-new nil 10)))
3019 (setf (container-border-width box2) 10)
3020 (box-pack-start box1 box2 nil t 0)
3022 (let ((button (button-new "insert random")))
3023 (signal-connect button 'clicked #'(lambda () nil))
3024 (box-pack-start box2 button t t 0))
3026 (let ((button (button-new "close")))
3030 (widget-destroy window)
3032 (box-pack-start box2 button t t 0)
3033 (setf (widget-can-default-p button) t)
3034 (widget-grab-default button)))))
3040 (define-standard-dialog create-toggle-buttons "Toggle Button"
3041 (setf (container-border-width main-box) 10)
3042 (setf (box-spacing main-box) 10)
3043 (box-pack main-box (toggle-button-new "button1"))
3044 (box-pack main-box (toggle-button-new "button2"))
3045 (box-pack main-box (toggle-button-new "button3")))
3051 (define-test-window create-toolbar "Toolbar test"
3052 (setf (window-allow-grow-p window) nil)
3053 (setf (window-allow-shrink-p window) t)
3054 (setf (window-auto-shrink-p window) t)
3055 (widget-realize window)
3058 (let ((toolbar (toolbar-new :horizontal :both)))
3059 (setf (toolbar-relief toolbar) :none)
3061 (toolbar-append-item
3062 toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
3063 :tooltip-text "Horizontal toolbar layout"
3064 :tooltip-private-text "Toolbar/Horizontal"
3065 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
3067 (toolbar-append-item
3068 toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm")
3069 :tooltip-text "Vertical toolbar layout"
3070 :tooltip-private-text "Toolbar/Vertical"
3071 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
3073 (toolbar-append-space toolbar)
3075 (toolbar-append-item
3076 toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm")
3077 :tooltip-text "Only show toolbar icons"
3078 :tooltip-private-text "Toolbar/IconsOnly"
3079 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
3081 (toolbar-append-item
3082 toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
3083 :tooltip-text "Only show toolbar text"
3084 :tooltip-private-text "Toolbar/TextOnly"
3085 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
3087 (toolbar-append-item
3088 toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm")
3089 :tooltip-text "Show toolbar icons and text"
3090 :tooltip-private-text "Toolbar/Both"
3091 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
3093 (toolbar-append-space toolbar)
3095 (toolbar-append-widget
3097 :tooltip-text "This is an unusable GtkEntry ;)"
3098 :tooltip-private-text "Hey don't click me!")
3100 (toolbar-append-space toolbar)
3102 (toolbar-append-item
3103 toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm")
3104 :tooltip-text "Use small spaces"
3105 :tooltip-private-text "Toolbar/Small"
3106 :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
3108 (toolbar-append-item
3109 toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm")
3110 :tooltip-text "Use big spaces"
3111 :tooltip-private-text "Toolbar/Big"
3112 :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
3114 (toolbar-append-space toolbar)
3116 (toolbar-append-item
3117 toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm")
3118 :tooltip-text "Enable tooltips"
3119 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
3121 (toolbar-append-item
3122 toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
3123 :tooltip-text "Disable tooltips"
3124 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
3126 (toolbar-append-space toolbar)
3128 (toolbar-append-item
3129 toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
3130 :tooltip-text "Show borders"
3131 :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
3133 (toolbar-append-item
3135 "Borderless" (pixmap-new "cl-gtk:src;test.xpm")
3136 :tooltip-text "Hide borders"
3137 :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
3139 (toolbar-append-space toolbar)
3141 (toolbar-append-item
3142 toolbar "Empty" (pixmap-new "cl-gtk:src;test.xpm")
3143 :tooltip-text "Empty spaces"
3144 :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
3146 (toolbar-append-item
3147 toolbar "Lines" (pixmap-new "cl-gtk:src;test.xpm")
3148 :tooltip-text "Lines in spaces"
3149 :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
3151 (container-add window toolbar)))
3157 (define-standard-dialog create-tooltips "Tooltips"
3158 (setf (window-allow-grow-p window) t)
3159 (setf (window-allow-shrink-p window) nil)
3160 (setf (window-auto-shrink-p window) t)
3161 (setf (widget-width window) 200)
3162 (setf (container-border-width main-box) 10)
3163 (setf (box-spacing main-box) 10)
3165 (let ((tooltips (tooltips-new)))
3167 (let ((button (toggle-button-new "button1")))
3168 (box-pack-start main-box button t t 0)
3170 tooltips button "This is button 1" "ContextHelp/button/1"))
3172 (let ((button (toggle-button-new "button2")))
3173 (box-pack-start main-box button t t 0)
3175 tooltips button "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."
3176 "ContextHelp/button/2"))
3178 (let ((toggle (toggle-button-new "Override TipSQuery Label")))
3179 (box-pack-start main-box toggle t t 0)
3181 tooltips toggle "Toggle TipsQuery view" "Hi msw! ;)")
3183 (let* ((box3 (make-vbox
3188 (tips-query (make-tips-query
3191 (button (make-button
3196 'clicked #'tips-query-start-query
3197 :object tips-query))))
3199 (box-set-child-packing box3 button nil nil 0 :start)
3201 tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
3202 (setf (tips-query-caller tips-query) button)
3205 tips-query 'widget-entered
3206 #'(lambda (widget tip-text tip-private)
3207 (declare (ignore widget tip-private))
3208 (when (toggle-button-active-p toggle)
3210 (label-text tips-query)
3213 "There is no Tip!"))
3214 (signal-emit-stop tips-query 'widget-entered))))
3217 tips-query 'widget-selected
3218 #'(lambda (widget tip-text tip-private event)
3219 (declare (ignore tip-text event))
3222 t "Help ~S requested for ~S~%"
3223 (or tip-private "None") (type-of widget)))
3226 (let ((frame (make-frame
3227 :label "ToolTips Inspector"
3233 (box-set-child-packing main-box frame t t 0 :start))
3236 tooltips close-button "Push this button to close window"
3237 "ContextHelp/buttons/Close")))))
3243 (defconstant +default-number-of-items+ 3)
3244 (defconstant +default-recursion-level+ 3)
3246 (defun create-subtree (item level nb-item-max recursion-level-max)
3247 (unless (and level (= level recursion-level-max))
3248 (multiple-value-bind (level item-subtree no-root-item)
3251 (values level (tree-new) nil))
3253 (dotimes (nb-item nb-item-max)
3255 (tree-item-new (format nil "item ~D-~D" level nb-item))))
3256 (tree-append item-subtree new-item)
3258 new-item (1+ level) nb-item-max recursion-level-max)
3259 (widget-show new-item)))
3261 (unless no-root-item
3262 (setf (tree-item-subtree item) item-subtree)))))
3265 (defun create-tree-sample (selection-mode draw-line view-line no-root-item
3266 nb-item-max recursion-level-max)
3267 (let ((window (window-new :toplevel)))
3268 (setf (window-title window) "Tree Sample")
3269 (signal-connect window 'destroy #'(lambda ()))
3271 (let ((box1 (vbox-new nil 0))
3272 (root-tree (tree-new))
3273 (add-button (button-new "Add Item"))
3274 (remove-button (button-new "Remove Item(s)"))
3275 (subtree-button (button-new "Remove Subtree")))
3276 (container-add window box1)
3279 (let ((box2 (vbox-new nil 0))
3280 (scrolled-win (scrolled-window-new nil nil)))
3281 (box-pack box1 box2)
3282 (setf (container-border-width box2) 5)
3284 (setf (scrolled-window-scrollbar-policy scrolled-win) :automatic)
3285 (box-pack box2 scrolled-win)
3286 (setf (widget-width scrolled-win) 200)
3287 (setf (widget-height scrolled-win) 200)
3288 (widget-show scrolled-win)
3290 root-tree 'selection-changed
3292 (format t "Selection: ~A~%" (tree-selection root-tree))
3293 (let ((nb-selected (length (tree-selection root-tree))))
3294 (if (zerop nb-selected)
3296 (if (container-children root-tree)
3297 (setf (widget-sensitive-p add-button) t)
3298 (setf (widget-sensitive-p add-button) nil))
3299 (setf (widget-sensitive-p remove-button) nil)
3300 (setf (widget-sensitive-p subtree-button) nil))
3302 (setf (widget-sensitive-p remove-button) t)
3303 (setf (widget-sensitive-p add-button) (= 1 nb-selected))
3305 (widget-sensitive-p subtree-button) (= 1 nb-selected)))))))
3306 (scrolled-window-add-with-viewport scrolled-win root-tree)
3307 (setf (tree-selection-mode root-tree) selection-mode)
3308 (setf (tree-view-lines-p root-tree) draw-line)
3309 (setf (tree-view-mode root-tree) (if view-line :line :item))
3310 (widget-show root-tree)
3315 (let ((root-item (tree-item-new "root item")))
3316 (tree-append root-tree root-item)
3317 (widget-show root-item)
3320 root-item (if no-root-item nil 0) nb-item-max recursion-level-max)))
3322 (let ((box2 (vbox-new nil 0)))
3323 (box-pack-start box1 box2 nil nil 0)
3324 (setf (container-border-width box2) 5)
3327 (setf (widget-sensitive-p add-button) nil)
3328 (let ((nb-item-add 0))
3332 (let* ((selected-list (tree-selection root-tree))
3333 (subtree (if (not selected-list)
3335 (let ((selected-item (first selected-list)))
3337 (tree-item-subtree selected-item)
3338 (let ((subtree (tree-new)))
3340 (tree-item-subtree selected-item)
3344 (tree-item-new (format nil "item add ~D" nb-item-add))))
3345 (tree-append subtree new-item)
3346 (widget-show new-item)
3347 (incf nb-item-add)))))
3348 (box-pack-start box2 add-button t t 0)
3349 (widget-show add-button)
3351 (setf (widget-sensitive-p remove-button) nil)
3353 remove-button 'clicked
3355 (format t "Remove: ~A~%" (tree-selection root-tree))
3356 (tree-remove-items root-tree (tree-selection root-tree))))
3357 (box-pack-start box2 remove-button t t 0)
3358 (widget-show remove-button)
3360 (setf (widget-sensitive-p subtree-button) nil)
3362 subtree-button 'clicked
3364 (let ((selected-list (tree-selection root-tree)))
3366 (let ((item (first selected-list)))
3368 (setf (tree-item-subtree item) nil)))))))
3369 (box-pack-start box2 subtree-button t t 0)
3370 (widget-show subtree-button))
3372 (let ((separator (hseparator-new)))
3373 (box-pack-start box1 separator nil nil 0)
3374 (widget-show separator))
3376 (let ((box2 (vbox-new nil 0))
3377 (button (button-new "Close")))
3378 (box-pack-start box1 box2 nil nil 0)
3379 (setf (container-border-width box2) 5)
3381 (box-pack-start box2 button t t 0)
3382 (signal-connect button 'clicked
3384 (widget-destroy window)))
3385 (widget-show button)))
3387 (widget-show window)))
3390 (define-test-window create-tree "Set Tree Parameters"
3391 (let ((box1 (vbox-new nil 0)))
3392 (container-add window box1)
3394 (let ((box2 (vbox-new nil 5)))
3395 (box-pack box1 box2)
3396 (setf (container-border-width box2) 5)
3398 (let ((box3 (hbox-new nil 5)))
3399 (box-pack box2 box3)
3401 (let* ((single-button (radio-button-new nil :label "SIGNLE"))
3404 (radio-button-group single-button) :label "BROWSE"))
3407 (radio-button-group single-button) :label "MULTIPLE"))
3408 (draw-line-button (check-button-new "Draw line"))
3409 (view-line-button (check-button-new "View Line mode"))
3410 (no-root-item-button (check-button-new "Without Root item"))
3411 (num-of-items-spinner
3414 +default-number-of-items+ 1 255 1 5 0)
3419 +default-recursion-level+ 0 255 1 5 0)
3422 (let ((frame (frame-new "Selection Mode"))
3423 (box4 (vbox-new nil 0)))
3424 (box-pack box3 frame)
3425 (container-add frame box4)
3426 (setf (container-border-width box4) 5)
3427 (box-pack box4 single-button)
3428 (box-pack box4 browse-button)
3429 (box-pack box4 multiple-button))
3431 (let ((frame (frame-new "Options"))
3432 (box4 (vbox-new nil 0)))
3433 (box-pack box3 frame)
3434 (container-add frame box4)
3435 (setf (container-border-width box4) 5)
3436 (box-pack box4 draw-line-button)
3437 (box-pack box4 view-line-button)
3438 (box-pack box4 no-root-item-button)
3439 (setf (toggle-button-active-p draw-line-button) t)
3440 (setf (toggle-button-active-p view-line-button) t)
3441 (setf (toggle-button-active-p no-root-item-button) nil))
3443 (let ((frame (frame-new "Size Parameters"))
3444 (box4 (vbox-new nil 5)))
3445 (box-pack box2 frame)
3446 (container-add frame box4)
3447 (setf (container-border-width box4) 5)
3449 (let ((box5 (hbox-new nil 5)))
3450 (box-pack box4 box5 :expand nil :fill nil)
3451 (let ((label (label-new "Number of items : ")))
3452 (setf (misc-xalign label) 0)
3453 (setf (misc-yalign label) 0.5)
3454 (box-pack box5 label :expand nil)
3455 (box-pack box5 num-of-items-spinner :expand nil))
3456 (let ((label (label-new "Depth : ")))
3457 (setf (misc-xalign label) 0)
3458 (setf (misc-yalign label) 0.5)
3459 (box-pack box5 label :expand nil)
3460 (box-pack box5 depth-spinner :expand nil))))
3462 (box-pack box1 (hseparator-new) :expand nil :fill nil)
3464 (let ((box2 (hbox-new t 10)))
3465 (box-pack box1 box2)
3466 (setf (container-border-width box2) 5)
3467 (let ((button (button-new "Create Tree")))
3468 (box-pack box2 button)
3472 (let ((selection-mode
3474 ((toggle-button-active-p single-button) :single)
3475 ((toggle-button-active-p browse-button) :browse)
3478 (toggle-button-active-p draw-line-button))
3480 (toggle-button-active-p view-line-button))
3482 (toggle-button-active-p no-root-item-button))
3484 (spin-button-value-as-int num-of-items-spinner))
3486 (spin-button-value-as-int depth-spinner)))
3488 (if (> (expt num-of-items depth) 10000)
3489 (format t "~D total items? That will take a very long time. Try less~%" (expt num-of-items depth))
3491 selection-mode draw-line view-line no-root-item
3492 num-of-items depth))))))
3493 (let ((button (button-new "Close")))
3494 (box-pack box2 button)
3496 button 'clicked #'widget-destroy :object window))))))))
3502 (defun create-main-window ()
3504 '(("button box" create-button-box)
3505 ("buttons" create-buttons)
3506 ("calendar" create-calendar)
3507 ("check buttons" create-check-buttons)
3508 ("clist" create-clist)
3509 ("color selection" create-color-selection)
3510 ("ctree" create-ctree)
3511 ("cursors" create-cursors)
3512 ("dialog" create-dialog)
3514 ("entry" create-entry)
3516 ("file selection" create-file-selection)
3519 ("handle box" create-handle-box)
3521 ("labels" create-labels)
3522 ("layout" create-layout)
3523 ("list" create-list)
3524 ("menus" create-menus)
3526 ("notebook" create-notebook)
3527 ("panes" create-panes)
3528 ("pixmap" create-pixmap)
3531 ("progress bar" create-progress-bar)
3532 ("radio buttons" create-radio-buttons)
3533 ("range controls" create-range-controls)
3535 ("reparent" create-reparent)
3536 ("rulers" create-rulers)
3538 ("scrolled windows" create-scrolled-windows)
3539 ("shapes" create-shapes)
3540 ("spinbutton" create-spins)
3541 ("statusbar" create-statusbar)
3542 ("test idle" create-idle-test)
3546 ("test timeout" create-timeout-test)
3547 ("text" create-text)
3548 ("toggle buttons" create-toggle-buttons)
3549 ("toolbar" create-toolbar)
3550 ("tooltips" create-tooltips)
3551 ("tree" create-tree)
3553 (main-window (make-instance 'window
3554 :type :toplevel :title "testgtk.lisp"
3555 :name "main window" :x 20 :y 20 :width 200 :height 400
3556 :allow-grow nil :allow-shrink nil :auto-shrink nil))
3557 (scrolled-window (make-instance 'scrolled-window
3558 :hscrollbar-policy :automatic
3559 :vscrollbar-policy :automatic
3561 (close-button (make-instance 'button
3563 :can-default t ;:has-default t
3567 'clicked #'widget-destroy :object main-window)))))
3570 (make-instance 'vbox
3575 (make-instance 'label :label (gtk-version))
3576 :expand nil :fill nil)
3578 (make-instance 'label :label (format nil "clg CVS version"))
3579 :expand nil :fill nil)
3581 (list (make-instance 'hseparator) :expand nil)
3583 (make-instance 'vbox
3584 :homogeneous nil :spacing 10 :border-width 10
3585 :children (list (list close-button :expand t :fill t)))
3589 (make-instance 'vbox
3591 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
3596 (let ((widget (make-instance 'button :label (first button))))
3598 (signal-connect widget 'clicked (second button))
3599 (setf (widget-sensitive-p widget) nil))
3603 (scrolled-window-add-with-viewport scrolled-window button-box))
3605 (widget-grab-default close-button)
3606 (widget-show-all main-window)
3610 (rc-parse "cl-gtk:src;testgtkrc2")
3611 (rc-parse "cl-gtk:src;testgtkrc")
3614 ;(create-main-window)