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.5 2004-11-08 14:16:12 espen Exp $
21 ;;; Some of the code in this file are really outdatet, but it is
22 ;;; still the most complete example of how to use the library
28 (defmacro define-toplevel (name (window title &rest initargs) &body body)
32 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
33 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
36 (if (not (widget-visible-p ,window))
37 (widget-show-all ,window)
38 (widget-hide ,window)))))
41 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
47 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
48 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
51 (if (not (widget-visible-p ,dialog))
53 (widget-hide ,dialog)))))
56 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
57 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
58 (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
63 ;;; Pixmaps used in some of the tests
105 (defvar book-closed-xpm
130 (defvar mini-page-xpm
153 (defvar book-open-xpm
180 (defun create-bbox-in-frame (class frame-label spacing width height layout)
181 (declare (ignore width height))
182 (make-instance 'frame
184 :child (make-instance class
185 :border-width 5 :layout-style layout :spacing spacing
186 ; :child-min-width width :child-min-height height
187 :child (make-instance 'button :label "OK")
188 :child (make-instance 'button :label "Cancel")
189 :child (make-instance 'button :label "Help"))))
191 (define-toplevel create-button-box (window "Button Boxes")
192 (make-instance 'v-box
193 :parent window :border-width 10 :spacing 10 :show-all t
194 :child (make-instance 'frame
195 :label "Horizontal Button Boxes"
196 :child (make-instance 'v-box
197 :border-width 10 :spacing 10
200 (apply #'create-bbox-in-frame
202 '(("Spread" 40 85 20 :spread)
203 ("Edge" 40 85 20 :edge)
204 ("Start" 40 85 20 :start)
205 ("End" 40 85 20 :end)))))
206 :child (make-instance 'frame
207 :label "Vertical Button Boxes"
208 :child (make-instance 'h-box
209 :border-width 10 :spacing 10
212 (apply #'create-bbox-in-frame
214 '(("Spread" 30 85 20 :spread)
215 ("Edge" 30 85 20 :edge)
216 ("Start" 30 85 20 :start)
217 ("End" 30 85 20 :end)))))))
222 (define-simple-dialog create-buttons (dialog "Buttons")
223 (let ((table (make-instance 'table
224 :n-rows 3 :n-columns 3 :homogeneous nil
225 :row-spacing 5 :column-spacing 5 :border-width 10
229 collect (make-instance 'button
230 :label (format nil "button~D" (1+ n))))))
234 (let ((button (nth (+ (* 3 row) column) buttons))
235 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
236 (signal-connect button 'clicked
238 (if (widget-visible-p button+1)
239 (widget-hide button+1)
240 (widget-show button+1))))
241 (table-attach table button column (1+ column) row (1+ row)))))
242 (widget-show-all table)))
247 (define-simple-dialog create-calendar (dialog "Calendar")
248 (make-instance 'v-box
249 :parent dialog :border-width 10 :show-all t
250 :child (make-instance 'calendar)))
255 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
256 (make-instance 'v-box
257 :border-width 10 :spacing 10 :parent dialog :show-all t
260 collect (make-instance 'check-button
261 :label (format nil "Button~D" n)))))
267 (define-dialog create-color-selection (dialog "Color selection dialog"
268 'color-selection-dialog
269 :allow-grow nil :allow-shrink nil)
270 (with-slots (action-area colorsel) dialog
271 ;; This seg faults for some unknown reason
272 ;; (let ((button (make-instance 'check-button :label "Show Palette")))
273 ;; (dialog-add-action-widget dialog button
276 ;; (color-selection-has-palette-p colorsel)
277 ;; (toggle-button-active-p button)))))
279 (container-add action-area
280 (create-check-button "Show Opacity"
282 (setf (color-selection-has-opacity-control-p colorsel) state))))
284 (container-add action-area
285 (create-check-button "Show Palette"
287 (setf (color-selection-has-palette-p colorsel) state))))
289 (signal-connect dialog :ok
291 (let ((color (color-selection-current-color colorsel)))
292 (format t "Selected color: ~A~%" color)
293 (setf (color-selection-current-color colorsel) color)
294 (widget-hide dialog))))
296 (signal-connect dialog :cancel #'widget-destroy :object t)))
301 (defun clamp (n min-val max-val)
302 (declare (number n min-val max-val))
303 (max (min n max-val) min-val))
306 ;; (defun set-cursor (spinner drawing-area label)
309 ;; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
310 ;; 'gdk:cursor-type)))
311 ;; (setf (label-text label) (string-downcase cursor))
312 ;; (setf (widget-cursor drawing-area) cursor)))
315 ; (define-standard-dialog create-cursors "Cursors"
316 ; (setf (container-border-width main-box) 10)
317 ; (setf (box-spacing main-box) 5)
318 ; (let* ((hbox (hbox-new nil 0))
319 ; (label (create-label "Cursor Value : "))
320 ; (adj (adjustment-new 0 0 152 2 10 0))
321 ; (spinner (spin-button-new adj 0 0)))
322 ; (setf (container-border-width hbox) 5)
323 ; (box-pack-start main-box hbox nil t 0)
324 ; (setf (misc-xalign label) 0)
325 ; (setf (misc-yalign label) 0.5)
326 ; (box-pack-start hbox label nil t 0)
327 ; (box-pack-start hbox spinner t t 0)
329 ; (let ((frame (make-frame
330 ; :shadow-type :etched-in
332 ; :label "Cursor Area"
336 ; (drawing-area (drawing-area-new)))
337 ; (setf (widget-width drawing-area) 80)
338 ; (setf (widget-height drawing-area) 80)
339 ; (container-add frame drawing-area)
341 ; drawing-area 'expose-event
343 ; (declare (ignore event))
344 ; (multiple-value-bind (width height)
345 ; (drawing-area-size drawing-area)
346 ; (let* ((drawable (widget-window drawing-area))
347 ; (style (widget-style drawing-area))
348 ; (white-gc (style-get-gc style :white))
349 ; (gray-gc (style-get-gc style :background :normal))
350 ; (black-gc (style-get-gc style :black)))
351 ; (gdk:draw-rectangle
352 ; drawable white-gc t 0 0 width (floor height 2))
353 ; (gdk:draw-rectangle
354 ; drawable black-gc t 0 (floor height 2) width (floor height 2))
355 ; (gdk:draw-rectangle
356 ; drawable gray-gc t (floor width 3) (floor height 3)
357 ; (floor width 3) (floor height 3))))
359 ; (setf (widget-events drawing-area) '(:exposure :button-press))
361 ; drawing-area 'button-press-event
364 ; (eq (gdk:event-type event) :button-press)
366 ; (= (gdk:event-button event) 1)
367 ; (= (gdk:event-button event) 3)))
370 ; (if (= (gdk:event-button event) 1)
375 ; (widget-show drawing-area)
377 ; (let ((label (make-label
380 ; :parent main-box)))
381 ; (setf (box-child-expand-p #|main-box|# label) nil)
385 ; (set-cursor spinner drawing-area label)))
387 ; (widget-realize drawing-area)
388 ; (set-cursor spinner drawing-area label)))))
395 (defun create-dialog ()
397 (setq dialog (make-instance 'dialog
398 :title "Dialog" :default-width 200
400 :button (list "gtk-ok" #'widget-destroy :object t)
401 :signal (list 'destroy
403 (setq dialog nil)))))
405 (let ((label (make-instance 'label
406 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
408 (signal-connect dialog "Toggle"
410 (if (widget-visible-p label)
412 (widget-show label))))))
414 (if (widget-visible-p dialog)
416 (widget-show dialog))))
421 (define-simple-dialog create-entry (dialog "Entry")
422 (let ((main (make-instance 'v-box
423 :border-width 10 :spacing 10 :parent dialog)))
425 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
426 (editable-select-region entry 0 5) ; this has no effect when
428 ;; (editable-insert-text entry "great " 6)
429 ;; (editable-delete-text entry 6 12)
431 (let ((combo (make-instance 'combo-box-entry
436 "item3 item3 item3 item3"
437 "item4 item4 item4 item4 item4"
438 "item5 item5 item5 item5 item5 item5"
439 "item6 item6 item6 item6 item6"
440 "item7 item7 item7 item7"
443 (with-slots (child) combo
444 (setf (editable-text child) "hello world")
445 (editable-select-region child 0)))
447 (flet ((create-check-button (label slot)
448 (make-instance 'check-button
449 :label label :active t :parent main
450 :signal (list 'toggled
452 (setf (slot-value entry slot)
453 (toggle-button-active-p button)))
456 (create-check-button "Editable" 'editable)
457 (create-check-button "Visible" 'visibility)
458 (create-check-button "Sensitive" 'sensitive)))
459 (widget-show-all main)))
463 ;; File chooser dialog
465 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
466 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
467 (dialog-add-button dialog "gtk-ok"
469 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
470 (widget-destroy dialog))))
476 ;; (defun create-handle-box-toolbar ()
477 ;; (let ((toolbar (toolbar-new :horizontal :both)))
478 ;; (toolbar-append-item
479 ;; toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
480 ;; :tooltip-text "Horizontal toolbar layout"
481 ;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
483 ;; (toolbar-append-item
484 ;; toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
485 ;; :tooltip-text "Vertical toolbar layout"
486 ;; :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
488 ;; (toolbar-append-space toolbar)
490 ;; (toolbar-append-item
491 ;; toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
492 ;; :tooltip-text "Only show toolbar icons"
493 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
495 ;; (toolbar-append-item
496 ;; toolbar "Text" (pixmap-new "clg:examples;test.xpm")
497 ;; :tooltip-text "Only show toolbar text"
498 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
500 ;; (toolbar-append-item
501 ;; toolbar "Both" (pixmap-new "clg:examples;test.xpm")
502 ;; :tooltip-text "Show toolbar icons and text"
503 ;; :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
505 ;; (toolbar-append-space toolbar)
507 ;; (toolbar-append-item
508 ;; toolbar "Small" (pixmap-new "clg:examples;test.xpm")
509 ;; :tooltip-text "Use small spaces"
510 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
512 ;; (toolbar-append-item
513 ;; toolbar "Big" (pixmap-new "clg:examples;test.xpm")
514 ;; :tooltip-text "Use big spaces"
515 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
517 ;; (toolbar-append-space toolbar)
519 ;; (toolbar-append-item
520 ;; toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
521 ;; :tooltip-text "Enable tooltips"
522 ;; :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
524 ;; (toolbar-append-item
525 ;; toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
526 ;; :tooltip-text "Disable tooltips"
527 ;; :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
529 ;; (toolbar-append-space toolbar)
531 ;; (toolbar-append-item
532 ;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
533 ;; :tooltip-text "Show borders"
534 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
536 ;; (toolbar-append-item
537 ;; toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
538 ;; :tooltip-text "Hide borders"
539 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
544 ;; (defun handle-box-child-signal (handle-box child action)
545 ;; (format t "~S: child ~S ~A~%" handle-box child action))
548 ;; (define-test-window create-handle-box "Handle Box Test"
549 ;; (setf (window-allow-grow-p window) t)
550 ;; (setf (window-allow-shrink-p window) t)
551 ;; (setf (window-auto-shrink-p window) nil)
552 ;; (setf (container-border-width window) 20)
553 ;; (let ((v-box (v-box-new nil 0)))
554 ;; (container-add window v-box)
556 ;; (container-add v-box (create-label "Above"))
557 ;; (container-add v-box (hseparator-new))
559 ;; (let ((hbox (hbox-new nil 10)))
560 ;; (container-add v-box hbox)
562 ;; (let ((handle-box (handle-box-new)))
563 ;; (box-pack-start hbox handle-box nil nil 0)
565 ;; handle-box 'child-attached
567 ;; (handle-box-child-signal handle-box child "attached")))
569 ;; handle-box 'child-detached
571 ;; (handle-box-child-signal handle-box child "detached")))
572 ;; (container-add handle-box (create-handle-box-toolbar)))
574 ;; (let ((handle-box (handle-box-new)))
575 ;; (box-pack-start hbox handle-box nil nil 0)
577 ;; handle-box 'child-attached
579 ;; (handle-box-child-signal handle-box child "attached")))
581 ;; handle-box 'child-detached
583 ;; (handle-box-child-signal handle-box child "detached")))
585 ;; (let ((handle-box2 (handle-box-new)))
586 ;; (container-add handle-box handle-box2)
588 ;; handle-box2 'child-attached
590 ;; (handle-box-child-signal handle-box child "attached")))
592 ;; handle-box2 'child-detached
594 ;; (handle-box-child-signal handle-box child "detached")))
595 ;; (container-add handle-box2 (create-label "Foo!")))))
597 ;; (container-add v-box (hseparator-new))
598 ;; (container-add v-box (create-label "Below"))))
602 (define-toplevel create-image (window "Image")
603 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
608 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
609 (flet ((create-label-in-frame (frame-label label-text &rest args)
611 (make-instance 'frame
613 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
614 :fill nil :expand nil)))
615 (make-instance 'h-box
616 :spacing 5 :parent window
617 :child-args '(:fill nil :expand nil)
618 :child (make-instance 'v-box
620 :child (create-label-in-frame "Normal Label" "This is a Normal label")
621 :child (create-label-in-frame "Multi-line Label"
622 "This is a Multi-line label.
625 :child (create-label-in-frame "Left Justified Label"
626 "This is a Left-Justified
630 :child (create-label-in-frame "Right Justified Label"
631 "This is a Right-Justified
635 :child (make-instance 'v-box
637 :child (create-label-in-frame "Line wrapped label"
638 "This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
639 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
642 :child (create-label-in-frame "Filled, wrapped label"
643 "This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do.
644 This is a new paragraph.
645 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
646 :justify :fill :wrap t)
648 :child (create-label-in-frame "Underlined label"
649 "This label is underlined!
650 This one is underlined (こんにちは) in quite a funky fashion"
652 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
657 ;; (defun layout-expose (layout event)
658 ;; (with-slots (window x-offset y-offset) layout
659 ;; (with-slots (x y width height) event
660 ;; (let ((imin (truncate (+ x-offset x) 10))
661 ;; (imax (truncate (+ x-offset x width 9) 10))
662 ;; (jmin (truncate (+ y-offset y) 10))
663 ;; (jmax (truncate (+ y-offset y height 9) 10)))
664 ;; (declare (fixnum imin imax jmin jmax))
665 ;; (gdk:window-clear-area window x y width height)
667 ;; (let ((window (layout-bin-window layout))
668 ;; (gc (style-get-gc (widget-style layout) :black)))
669 ;; (do ((i imin (1+ i)))
671 ;; (declare (fixnum i))
672 ;; (do ((j jmin (1+ j)))
674 ;; (declare (fixnum j))
675 ;; (unless (zerop (mod (+ i j) 2))
676 ;; (gdk:draw-rectangle
678 ;; (- (* 10 i) x-offset) (- (* 10 j) y-offset)
679 ;; (1+ (mod i 10)) (1+ (mod j 10))))))))))
683 (define-toplevel create-layout (window "Layout" :default-width 200
685 (let ((layout (make-instance 'layout
686 :parent (make-instance 'scrolled-window :parent window)
687 :width 1600 :height 128000 :events '(:exposure-mask)
688 ;; :signal (list 'expose-event #'layout-expose :object t)
691 (with-slots (hadjustment vadjustment) layout
693 (adjustment-step-increment hadjustment) 10.0
694 (adjustment-step-increment vadjustment) 10.0))
698 (let ((text (format nil "Button ~D, ~D" i j)))
699 (make-instance (if (not (zerop (mod (+ i j) 2)))
702 :label text :parent (list layout :x (* j 100) :y (* i 100))))))
705 for i from 16 below 1280
706 do (let ((text (format nil "Button ~D, ~D" i 0)))
707 (make-instance (if (not (zerop (mod i 2)))
710 :label text :parent (list layout :x 0 :y (* i 100)))))))
716 ;; (define-standard-dialog create-list "List"
717 ;; (let ((scrolled-window (scrolled-window-new))
718 ;; (list (list-new)))
719 ;; (setf (container-border-width scrolled-window) 5)
720 ;; (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
721 ;; (box-pack-start main-box scrolled-window t t 0)
722 ;; (setf (widget-height scrolled-window) 300)
724 ;; (setf (list-selection-mode list) :extended)
725 ;; (scrolled-window-add-with-viewport scrolled-window list)
727 ;; (container-focus-vadjustment list)
728 ;; (scrolled-window-vadjustment scrolled-window))
730 ;; (container-focus-hadjustment list)
731 ;; (scrolled-window-hadjustment scrolled-window))
733 ;; (with-open-file (file "clg:examples;gtktypes.lisp")
734 ;; (labels ((read-file ()
735 ;; (let ((line (read-line file nil nil)))
737 ;; (container-add list (list-item-new line))
741 ;; (let ((hbox (hbox-new t 5)))
742 ;; (setf (container-border-width hbox) 5)
743 ;; (box-pack-start main-box hbox nil t 0)
745 ;; (let ((button (button-new "Insert Row"))
747 ;; (box-pack-start hbox button t t 0)
752 ;; (list-item-new (format nil "added item ~A" (incf i)))))
753 ;; (widget-show item)
754 ;; (container-add list item)))))
756 ;; (let ((button (button-new "Clear List")))
757 ;; (box-pack-start hbox button t t 0)
759 ;; button 'clicked #'(lambda () (list-clear-items list 0 -1))))
761 ;; (let ((button (button-new "Remove Selection")))
762 ;; (box-pack-start hbox button t t 0)
766 ;; (let ((selection (list-selection list)))
767 ;; (if (eq (list-selection-mode list) :extended)
769 ;; (container-focus-child list)
770 ;; (first selection))))
772 ;; (let* ((children (container-children list))
777 ;; (eq (widget-state item) :selected))
778 ;; (member item children))
781 ;; (eq (widget-state item) :selected))
782 ;; (member item (reverse children))))))
783 ;; (list-remove-items list selection)
785 ;; (list-select-child list sel-row)))))
786 ;; (list-remove-items list selection)))))
787 ;; (box-pack-start hbox button t t 0)))
789 ;; (let ((cbox (hbox-new nil 0)))
790 ;; (box-pack-start main-box cbox nil t 0)
792 ;; (let ((hbox (hbox-new nil 5))
794 ;; (create-option-menu
796 ;; ,#'(lambda () (setf (list-selection-mode list) :single)))
798 ;; ,#'(lambda () (setf (list-selection-mode list) :browse)))
800 ;; ,#'(lambda () (setf (list-selection-mode list) :multiple)))
802 ;; ,#'(lambda () (setf (list-selection-mode list) :extended))))
805 ;; (setf (container-border-width hbox) 5)
806 ;; (box-pack-start cbox hbox t nil 0)
807 ;; (box-pack-start hbox (create-label "Selection Mode :") nil t 0)
808 ;; (box-pack-start hbox option-menu nil t 0)))))
814 (defun create-menu (depth tearoff)
815 (unless (zerop depth)
816 (let ((menu (make-instance 'menu)))
818 (let ((menu-item (make-instance 'tearoff-menu-item)))
819 (menu-shell-append menu menu-item)))
823 (make-instance 'radio-menu-item
824 :label (format nil "item ~2D - ~D" depth (1+ i)))))
826 (radio-menu-item-add-to-group menu-item group)
827 (setq group menu-item))
828 (unless (zerop (mod depth 2))
829 (setf (check-menu-item-active-p menu-item) t))
830 (menu-shell-append menu menu-item)
832 (setf (widget-sensitive-p menu-item) nil))
833 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
837 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
838 (let* ((main (make-instance 'v-box :parent dialog))
839 ; (accel-group (make-instance 'accel-group))
840 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
841 ; (accel-group-attach accel-group window)
843 (let ((menu-item (make-instance 'menu-item
844 :label (format nil "test~%line2"))))
845 (setf (menu-item-submenu menu-item) (create-menu 2 t))
846 (menu-shell-append menubar menu-item))
848 (let ((menu-item (make-instance 'menu-item :label "foo")))
849 (setf (menu-item-submenu menu-item) (create-menu 3 t))
850 (menu-shell-append menubar menu-item))
852 (let ((menu-item (make-instance 'menu-item :label "bar")))
853 (setf (menu-item-submenu menu-item) (create-menu 4 t))
854 (setf (menu-item-right-justified-p menu-item) t)
855 (menu-shell-append menubar menu-item))
857 (make-instance 'v-box
858 :spacing 10 :border-width 10 :parent main
859 :child (make-instance 'combo-box
863 collect (format nil "Item ~D" i))))
865 (widget-show-all main)))
870 (defun create-notebook-page (notebook page-num)
871 (let* ((title (format nil "Page ~D" page-num))
872 (page (make-instance 'frame :label title :border-width 10))
873 (v-box (make-instance 'v-box
874 :homogeneous t :border-width 10 :parent page)))
876 (make-instance 'h-box
877 :parent (list v-box :fill nil :padding 5) :homogeneous t
878 :child-args '(:padding 5)
879 :child (make-instance 'check-button
880 :label "Fill Tab" :active t
881 :signal (list 'toggled
884 (notebook-child-tab-fill-p page)
885 (toggle-button-active-p button)))
887 :child (make-instance 'check-button
889 :signal (list 'toggled
892 (notebook-child-tab-expand-p page)
893 (toggle-button-active-p button)))
895 :child (make-instance 'check-button
897 :signal (list 'toggled
900 (notebook-child-tab-pack page)
901 (if (toggle-button-active-p button)
905 :child (make-instance 'button
907 :signal (list 'clicked #'(lambda () (widget-hide page)))))
909 (let ((label-box (make-instance 'h-box
911 :child-args '(:expand nil)
912 :child (make-instance 'image :pixmap book-closed-xpm)
913 :child (make-instance 'label :label title)))
914 (menu-box (make-instance 'h-box
916 :child-args '(:expand nil)
917 :child (make-instance 'image :pixmap book-closed-xpm)
918 :child (make-instance 'label :label title))))
920 (widget-show-all page)
921 (notebook-append notebook page label-box menu-box))))
924 (define-simple-dialog create-notebook (dialog "Notebook")
925 (let ((main (make-instance 'v-box :parent dialog)))
926 (let ((notebook (make-instance 'notebook
927 :border-width 10 :tab-pos :top :parent main)))
928 (flet ((set-image (page func xpm)
929 (image-set-from-pixmap-data
930 (first (container-children (funcall func notebook page)))
932 (signal-connect notebook 'switch-page
933 #'(lambda (pointer page)
934 (declare (ignore pointer))
935 (unless (eq page (notebook-current-page-num notebook))
936 (set-image page #'notebook-menu-label book-open-xpm)
937 (set-image page #'notebook-tab-label book-open-xpm)
939 (let ((curpage (notebook-current-page notebook)))
941 (set-image curpage #'notebook-menu-label book-closed-xpm)
942 (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
943 (loop for i from 1 to 5 do (create-notebook-page notebook i))
945 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
947 (make-instance 'h-box
948 :spacing 5 :border-width 10
949 :parent (list main :expand nil)
950 :child-args '(:fill nil)
951 :child (make-instance 'check-button
953 :signal (list 'clicked
955 (if (toggle-button-active-p button)
956 (notebook-popup-enable notebook)
957 (notebook-popup-disable notebook)))
959 :child (make-instance 'check-button
960 :label "Homogeneous tabs"
961 :signal (list 'clicked
964 (notebook-homogeneous-p notebook)
965 (toggle-button-active-p button)))
968 (make-instance 'h-box
969 :spacing 5 :border-width 10
970 :parent (list main :expand nil)
971 :child-args '(:expand nil)
972 :child (make-instance 'label :label "Notebook Style: ")
973 :child (let ((scrollable-p nil))
974 ;; option menu is deprecated, we should use combo-box
975 (make-instance 'combo-box
976 :content '("Standard" "No tabs" "Scrollable") :active 0
977 :signal (list 'changed
978 #'(lambda (combo-box)
979 (case (combo-box-active combo-box)
981 (setf (notebook-show-tabs-p notebook) t)
983 (setq scrollable-p nil)
984 (setf (notebook-scrollable-p notebook) nil)
986 do (notebook-remove-page notebook 5))))
988 (setf (notebook-show-tabs-p notebook) nil)
990 (setq scrollable-p nil)
991 (setf (notebook-scrollable-p notebook) nil)
993 do (notebook-remove-page notebook 5))))
996 (setq scrollable-p t)
997 (setf (notebook-show-tabs-p notebook) t)
998 (setf (notebook-scrollable-p notebook) t)
999 (loop for i from 6 to 15
1000 do (create-notebook-page notebook i))))))
1002 :child (make-instance 'button
1003 :label "Show all Pages"
1004 :signal (list 'clicked
1006 (map-container nil #'widget-show notebook)))))
1008 (make-instance 'h-box
1009 :spacing 5 :border-width 10
1010 :parent (list main :expand nil)
1011 :child (make-instance 'button
1013 :signal (list 'clicked #'notebook-prev-page :object notebook))
1014 :child (make-instance 'button
1016 :signal (list 'clicked #'notebook-next-page :object notebook))
1017 :child (make-instance 'button
1019 :signal (let ((tab-pos 0))
1022 (setq tab-pos (mod (1+ tab-pos) 4))
1024 (notebook-tab-pos notebook)
1025 (svref #(:top :right :bottom :left) tab-pos))))))))
1026 (widget-show-all main)))
1031 (defun toggle-resize (child)
1032 (let* ((paned (widget-parent child))
1033 (is-child1-p (eq child (paned-child1 paned))))
1034 (multiple-value-bind (child resize shrink)
1036 (paned-child1 paned)
1037 (paned-child2 paned))
1038 (container-remove paned child)
1040 (paned-pack1 paned child (not resize) shrink)
1041 (paned-pack2 paned child (not resize) shrink)))))
1043 (defun toggle-shrink (child)
1044 (let* ((paned (widget-parent child))
1045 (is-child1-p (eq child (paned-child1 paned))))
1046 (multiple-value-bind (child resize shrink)
1048 (paned-child1 paned)
1049 (paned-child2 paned))
1050 (container-remove paned child)
1052 (paned-pack1 paned child resize (not shrink))
1053 (paned-pack2 paned child resize (not shrink))))))
1055 (defun create-pane-options (paned frame-label label1 label2)
1056 (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
1057 (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
1060 (table-attach table (create-label label1) 0 1 0 1)
1061 (let ((check-button (make-instance 'check-button :label "Resize")))
1062 (table-attach table check-button 0 1 1 2)
1064 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1065 (let ((check-button (make-instance 'check-button :label "Shrink")))
1066 (table-attach table check-button 0 1 2 3)
1067 (setf (toggle-button-active-p check-button) t)
1069 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1071 (table-attach table (create-label label2) 1 2 0 1)
1072 (let ((check-button (make-instance 'check-button :label "Resize")))
1073 (table-attach table check-button 1 2 1 2)
1074 (setf (toggle-button-active-p check-button) t)
1076 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1077 (let ((check-button (make-instance 'check-button :label "Shrink")))
1078 (table-attach table check-button 1 2 2 3)
1079 (setf (toggle-button-active-p check-button) t)
1081 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1084 (define-toplevel create-panes (window "Panes")
1085 (let* ((hpaned (make-instance 'h-paned
1086 :child1 (make-instance 'frame
1087 :width-request 60 :height-request 60
1089 :child (make-instance 'buttun :label "Hi there"))
1090 :child2 (make-instance 'frame
1091 :width-request 80 :height-request 60
1093 (vpaned (make-instance 'v-paned
1096 :child2 (make-instance 'frame
1097 :width-request 80 :height-request 60
1098 :shadow-type :in))))
1100 (make-instance 'v-box
1102 :child-args '(:expand nil)
1103 :child (list vpaned :expand t)
1104 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1105 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1115 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1116 (make-instance 'v-box
1117 :parent dialog :border-width 10 :spacing 10 :show-all t
1118 :children (create-radio-button-group '("button1" "button2" "button3") 1)))
1123 (define-simple-dialog create-range-controls (dialog "Range controls")
1124 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1125 (make-instance 'v-box
1126 :parent dialog :border-width 10 :spacing 10 :show-all t
1127 :child (make-instance 'h-scale
1128 :width-request 150 :adjustment adjustment :inverted t
1129 :update-policy :delayed :digits 1 :draw-value t)
1130 :child (make-instance 'h-scrollbar
1131 :adjustment adjustment :update-policy :continuous))))
1136 (define-simple-dialog create-reparent (dialog "Reparent")
1137 (let ((main (make-instance 'h-box
1138 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1139 (label (make-instance 'label :label "Hellow World")))
1141 (flet ((create-frame (title)
1142 (let* ((frame (make-instance 'frame :label title :parent main))
1143 (box (make-instance 'v-box
1144 :spacing 5 :border-width 5 :parent frame))
1145 (button (make-instance 'button
1146 :label "switch" :parent (list box :expand nil))))
1147 (signal-connect button 'clicked
1149 (widget-reparent label box)))
1152 (box-pack-start (create-frame "Frame 1") label nil t 0)
1153 (create-frame "Frame 2"))
1154 (widget-show-all main)))
1159 (define-toplevel create-rulers (window "Rulers"
1160 :default-width 300 :default-height 300
1161 ;; :events '(:pointer-motion-mask
1162 ;; :pointer-motion-hint-mask)
1165 (widget-events window)
1166 '(:pointer-motion-mask :pointer-motion-hint-mask))
1168 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
1169 (let ((ruler (make-instance 'h-ruler
1170 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1171 :position 0.0d0 :max-size 20.0d0)))
1172 (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1173 (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
1174 (let ((ruler (make-instance 'v-ruler
1175 :lower 5.0d0 :upper 15.0d0
1176 :position 0.0d0 :max-size 20.0d0)))
1177 (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1178 (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
1184 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1186 :default-height 300)
1187 (let* ((scrolled-window
1188 (make-instance 'scrolled-window
1189 :parent dialog :border-width 10
1190 :vscrollbar-policy :automatic
1191 :hscrollbar-policy :automatic))
1193 (make-instance 'table
1194 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1195 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1196 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1198 (scrolled-window-add-with-viewport scrolled-window table)
1202 (make-instance 'toggle-button
1203 :label (format nil "button (~D,~D)~%" i j))))
1204 (table-attach table button i (1+ i) j (1+ j)))))
1205 (widget-show-all scrolled-window)))
1210 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1212 ;; (make-instance 'window
1213 ;; :type type :x x :y y
1214 ;; :events '(:button-motion :pointer-motion-hint :button-press)))
1216 ;; (make-instance 'fixed
1217 ;; :parent window :width 100 :height 100)))
1219 ;; (widget-realize window)
1220 ;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1221 ;; (let ((pixmap (pixmap-new source mask))
1224 ;; (declare (fixnum x-offset y-offset))
1225 ;; (fixed-put fixed pixmap px py)
1226 ;; (widget-shape-combine-mask window mask px py)
1228 ;; (signal-connect window 'button-press-event
1229 ;; #'(lambda (event)
1230 ;; (when (typep event 'gdk:button-press-event)
1231 ;; (setq x-offset (truncate (gdk:event-x event)))
1232 ;; (setq y-offset (truncate (gdk:event-y event)))
1233 ;; (grab-add window)
1234 ;; (gdk:pointer-grab
1235 ;; (widget-window window) t
1236 ;; '(:button-release :button-motion :pointer-motion-hint)
1240 ;; (signal-connect window 'button-release-event
1241 ;; #'(lambda (event)
1242 ;; (declare (ignore event))
1243 ;; (grab-remove window)
1244 ;; (gdk:pointer-ungrab 0)
1247 ;; (signal-connect window 'motion-notify-event
1248 ;; #'(lambda (event)
1249 ;; (declare (ignore event))
1250 ;; (multiple-value-bind (win xp yp mask)
1251 ;; (gdk:window-get-pointer root-window)
1252 ;; (declare (ignore mask win) (fixnum xp yp))
1253 ;; (widget-set-uposition
1254 ;; window :x (- xp x-offset) :y (- yp y-offset)))
1256 ;; (signal-connect window 'destroy destroy)))
1258 ;; (widget-show-all window)
1262 ;; (let ((modeller nil)
1265 ;; (defun create-shapes ()
1266 ;; (let ((root-window (gdk:get-root-window)))
1267 ;; (if (not modeller)
1270 ;; (shape-create-icon
1271 ;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1272 ;; #'(lambda () (widget-destroyed modeller))))
1273 ;; (widget-destroy modeller))
1278 ;; (shape-create-icon
1279 ;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1280 ;; #'(lambda () (widget-destroyed sheets))))
1281 ;; (widget-destroy sheets))
1286 ;; (shape-create-icon
1287 ;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1288 ;; #'(lambda () (widget-destroyed rings))))
1289 ;; (widget-destroy rings)))))
1295 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1296 (let ((main (make-instance 'v-box
1297 :spacing 5 :border-width 10 :parent dialog)))
1299 (flet ((create-date-spinner (label adjustment shadow-type)
1300 (declare (ignore shadow-type))
1301 (make-instance 'v-box
1302 :child-args '(:expand nil)
1303 :child (make-instance 'label
1304 :label label :xalign 0.0 :yalign 0.5)
1305 :child (make-instance 'spin-button
1306 :adjustment adjustment :wrap t))))
1307 (make-instance 'frame
1308 :label "Not accelerated" :parent main
1309 :child (make-instance 'h-box
1311 :child-args '(:padding 5)
1312 :child (create-date-spinner "Day : "
1313 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1314 :child (create-date-spinner "Month : "
1315 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1316 :child (create-date-spinner "Year : "
1317 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1319 (let ((spinner1 (make-instance 'spin-button
1320 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1321 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1322 (spinner2 (make-instance 'spin-button
1323 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1324 :climb-rate 1.0 :wrap t))
1325 (value-label (make-instance 'label :label "0")))
1326 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1329 (spin-button-digits spinner1)
1330 (floor (spin-button-value spinner2)))))
1332 (make-instance 'frame
1333 :label "Accelerated" :parent main
1334 :child (make-instance 'v-box
1337 (make-instance 'h-box
1338 :child-args '(:padding 5)
1339 :child (make-instance 'v-box
1340 :child (make-instance 'label
1342 :xalign 0.0 :yalign 0.5)
1344 :child (make-instance 'v-box
1345 :child (make-instance 'label
1347 :xalign 0.0 :yalign 0.5)
1349 :expand nil :padding 5)
1350 :child (make-instance 'check-button
1351 :label "Snap to 0.5-ticks" :active t
1352 :signal (list 'clicked
1355 (spin-button-snap-to-ticks-p spinner1)
1356 (toggle-button-active-p button)))
1358 :child (make-instance 'check-button
1359 :label "Numeric only input mode" :active t
1360 :signal (list 'clicked
1363 (spin-button-numeric-p spinner1)
1364 (toggle-button-active-p button)))
1368 (make-instance 'h-box
1369 :child-args '(:padding 5)
1370 :child (make-instance 'button
1371 :label "Value as Int"
1372 :signal (list 'clicked
1375 (label-label value-label)
1377 (spin-button-value-as-int
1379 :child (make-instance 'button
1380 :label "Value as Float"
1381 :signal (list 'clicked
1384 (label-label value-label)
1386 (format nil "~~,~DF"
1387 (spin-button-digits spinner1))
1388 (spin-button-value spinner1)))))))
1389 :padding 5 :expand nil))))
1390 (widget-show-all main)))
1395 (define-toplevel create-statusbar (window "Statusbar")
1396 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1397 (close-button (create-button '("close" :can-default t)
1398 #'widget-destroy :object window))
1401 (signal-connect statusbar 'text-popped
1402 #'(lambda (context-id text)
1403 (declare (ignore context-id))
1404 (format nil "Popped: ~A~%" text)))
1406 (make-instance 'v-box
1408 :child (make-instance 'v-box
1409 :border-width 10 :spacing 10
1410 :child (create-button "push something"
1412 (statusbar-push statusbar 1
1413 (format nil "something ~D" (incf counter)))))
1414 :child (create-button "pop"
1416 (statusbar-pop statusbar 1)))
1417 :child (create-button "steal #4"
1419 (statusbar-remove statusbar 1 4)))
1420 :child (create-button "dump stack")
1421 :child (create-button "test contexts"))
1422 :child (list (make-instance 'h-separator) :expand nil)
1424 (make-instance 'v-box :border-width 10 :child close-button)
1426 :child (list statusbar :expand nil))
1428 (widget-grab-focus close-button)))
1433 ;; (define-standard-dialog create-idle-test "Idle Test"
1434 ;; (let* ((container (make-instance 'hbox :parent main-box))
1435 ;; (label (make-instance 'label
1436 ;; :label "count: 0" :xpad 10 :ypad 10 :parent container))
1439 ;; (declare (fixnum count))
1441 ;; window 'destroy #'(lambda () (when idle (idle-remove idle))))
1443 ;; (make-instance 'frame
1444 ;; :label "Label Container" :border-width 5 :parent main-box
1446 ;; (make-instance 'v-box
1448 ;; (create-radio-button-group
1449 ;; '(("Resize-Parent" :parent)
1450 ;; ("Resize-Queue" :queue)
1451 ;; ("Resize-Immediate" :immediate))
1453 ;; '(setf container-resize-mode) container)))
1455 ;; (make-instance 'button
1456 ;; :label "start" :can-default t :parent action-area
1468 ;; (setf (label-label label) (format nil "count: ~D" count))
1471 ;; (make-instance 'button
1472 ;; :label "stop" :can-default t :parent action-area
1479 ;; (idle-remove idle)
1480 ;; (setq idle nil))))))))
1486 ;; (define-standard-dialog create-timeout-test "Timeout Test"
1487 ;; (let ((label (make-instance 'label
1488 ;; :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1491 ;; (declare (fixnum count))
1493 ;; window 'destroy #'(lambda () (when timer (timeout-remove timer))))
1495 ;; (make-instance 'button
1496 ;; :label "start" :can-default t :parent action-area
1509 ;; (setf (label-label label) (format nil "count: ~D" count))
1512 ;; (make-instance 'button
1513 ;; :label "stop" :can-default t :parent action-area
1520 ;; (timeout-remove timer)
1521 ;; (setq timer nil))))))))
1526 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1527 (make-instance 'v-box
1528 :border-width 10 :spacing 10 :parent dialog :show-all t
1531 collect (make-instance 'toggle-button
1532 :label (format nil "Button~D" (1+ n))))))
1538 ;; TODO: style properties
1539 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1540 (let ((toolbar (make-instance 'toolbar :parent window)))
1541 ; (setf (toolbar-relief toolbar) :none)
1543 ;; Insert a stock item
1544 (toolbar-append toolbar "gtk-quit"
1545 :tooltip-text "Destroy toolbar"
1546 :tooltip-private-text "Toolbar/Quit"
1547 :callback #'(lambda () (widget-destroy window)))
1549 ;; Image widge as icon
1550 (toolbar-append toolbar "Horizontal"
1551 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1552 :tooltip-text "Horizontal toolbar layout"
1553 :tooltip-private-text "Toolbar/Horizontal"
1554 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1557 (toolbar-append toolbar "Vertical"
1558 :icon #p"clg:examples;test.xpm"
1559 :tooltip-text "Vertical toolbar layout"
1560 :tooltip-private-text "Toolbar/Vertical"
1561 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1563 (toolbar-append toolbar :space)
1566 (toolbar-append toolbar "Icons"
1568 :tooltip-text "Only show toolbar icons"
1569 :tooltip-private-text "Toolbar/IconsOnly"
1570 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1572 ;; Icon from pixmap data
1573 (toolbar-append toolbar "Text"
1575 :tooltip-text "Only show toolbar text"
1576 :tooltip-private-text "Toolbar/TextOnly"
1577 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1579 (toolbar-append toolbar "Both"
1580 :tooltip-text "Show toolbar icons and text"
1581 :tooltip-private-text "Toolbar/Both"
1582 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1584 (toolbar-append toolbar :space)
1586 (toolbar-append toolbar (make-instance 'entry)
1587 :tooltip-text "This is an unusable GtkEntry"
1588 :tooltip-private-text "Hey don't click me!")
1590 (toolbar-append toolbar :space)
1592 ;; (toolbar-append-item
1593 ;; toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1594 ;; :tooltip-text "Use small spaces"
1595 ;; :tooltip-private-text "Toolbar/Small"
1596 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1598 ;; (toolbar-append-item
1599 ;; toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1600 ;; :tooltip-text "Use big spaces"
1601 ;; :tooltip-private-text "Toolbar/Big"
1602 ;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1604 ;; (toolbar-append toolbar :space)
1608 :tooltip-text "Enable tooltips"
1609 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1613 :tooltip-text "Disable tooltips"
1614 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1616 (toolbar-append toolbar :space)
1618 ;; (toolbar-append-item
1619 ;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1620 ;; :tooltip-text "Show borders"
1621 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1623 ;; (toolbar-append-item
1625 ;; "Borderless" (pixmap-new "clg:examples;test.xpm")
1626 ;; :tooltip-text "Hide borders"
1627 ;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1629 ;; (toolbar-append toolbar :space)
1631 ;; (toolbar-append-item
1632 ;; toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1633 ;; :tooltip-text "Empty spaces"
1634 ;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1636 ;; (toolbar-append-item
1637 ;; toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1638 ;; :tooltip-text "Lines in spaces"
1639 ;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1647 ;; (define-standard-dialog create-tooltips "Tooltips"
1649 ;; (window-allow-grow-p window) t
1650 ;; (window-allow-shrink-p window) nil
1651 ;; (window-auto-shrink-p window) t
1652 ;; (widget-width window) 200
1653 ;; (container-border-width main-box) 10
1654 ;; (box-spacing main-box) 10)
1656 ;; (let ((tooltips (tooltips-new)))
1657 ;; (flet ((create-button (label tip-text tip-private)
1658 ;; (let ((button (make-instance 'toggle-button
1659 ;; :label label :parent main-box)))
1660 ;; (tooltips-set-tip tooltips button tip-text tip-private)
1662 ;; (create-button "button1" "This is button 1" "ContextHelp/button/1")
1663 ;; (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")
1665 ;; (let* ((toggle (create-button "Override TipSQuery Label"
1666 ;; "Toggle TipsQuery view" "Hi msw! ;)"))
1667 ;; (box (make-instance 'v-box
1668 ;; :homogeneous nil :spacing 5 :border-width 5
1669 ;; :parent (make-instance 'frame
1670 ;; :label "ToolTips Inspector"
1671 ;; :label-xalign 0.5 :border-width 0
1672 ;; :parent main-box)))
1673 ;; (button (make-instance 'button :label "[?]" :parent box))
1674 ;; (tips-query (make-instance 'tips-query
1675 ;; :caller button :parent box)))
1678 ;; button 'clicked #'tips-query-start-query :object tips-query)
1681 ;; tips-query 'widget-entered
1682 ;; #'(lambda (widget tip-text tip-private)
1683 ;; (declare (ignore widget tip-private))
1684 ;; (when (toggle-button-active-p toggle)
1686 ;; (label-label tips-query)
1688 ;; "There is a Tip!"
1689 ;; "There is no Tip!"))
1690 ;; (signal-emit-stop tips-query 'widget-entered))))
1693 ;; tips-query 'widget-selected
1694 ;; #'(lambda (widget tip-text tip-private event)
1695 ;; (declare (ignore tip-text event))
1698 ;; t "Help ~S requested for ~S~%"
1699 ;; (or tip-private "None") (type-of widget)))
1702 ;; (tooltips-set-tip
1703 ;; tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1704 ;; (tooltips-set-tip
1705 ;; tooltips close-button "Push this button to close window"
1706 ;; "ContextHelp/buttons/Close")))))
1712 (defun create-main-window ()
1713 ;; (rc-parse "clg:examples;testgtkrc2")
1714 ;; (rc-parse "clg:examples;testgtkrc")
1716 (let* ((button-specs
1717 '(("button box" create-button-box)
1718 ("buttons" create-buttons)
1719 ("calendar" create-calendar)
1720 ("check buttons" create-check-buttons)
1721 ;; ("clist" #|create-clist|#)
1722 ("color selection" create-color-selection)
1723 ;; ("ctree" #|create-ctree|#)
1724 ;; ("cursors" #|create-cursors|#)
1725 ("dialog" create-dialog)
1727 ("entry" create-entry)
1728 ;; ("event watcher")
1729 ("file chooser" create-file-chooser)
1730 ;; ("font selection")
1731 ;; ("handle box" create-handle-box)
1732 ("image" create-image)
1734 ("labels" create-labels)
1735 ("layout" create-layout)
1736 ;; ("list" create-list)
1737 ("menus" create-menus)
1739 ("notebook" create-notebook)
1740 ("panes" create-panes)
1741 ;; ("progress bar" #|create-progress-bar|#)
1742 ("radio buttons" create-radio-buttons)
1743 ("range controls" create-range-controls)
1745 ("reparent" create-reparent)
1746 ("rulers" create-rulers)
1747 ;; ("saved position")
1748 ("scrolled windows" create-scrolled-windows)
1749 ;; ("shapes" create-shapes)
1750 ("spinbutton" create-spins)
1751 ("statusbar" create-statusbar)
1752 ;; ("test idle" create-idle-test)
1753 ;; ("test mainloop")
1754 ;; ("test scrolling")
1755 ;; ("test selection")
1756 ;; ("test timeout" create-timeout-test)
1757 ;; ("text" #|create-text|#)
1758 ("toggle buttons" create-toggle-buttons)
1759 ("toolbar" create-toolbar)
1760 ;; ("tooltips" create-tooltips)
1761 ;; ("tree" #|create-tree|#)
1763 (main-window (make-instance 'window
1764 :title "testgtk.lisp" :name "main_window"
1765 :default-width 200 :default-height 400
1766 :allow-grow t :allow-shrink nil))
1767 (scrolled-window (make-instance 'scrolled-window
1768 :hscrollbar-policy :automatic
1769 :vscrollbar-policy :automatic
1771 (close-button (make-instance 'button
1772 :label "close" :can-default t
1773 :signal (list 'clicked #'widget-destroy
1774 :object main-window))))
1777 (make-instance 'v-box
1779 :child-args '(:expand nil)
1780 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1781 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1782 :child (list scrolled-window :expand t)
1783 :child (make-instance 'h-separator)
1784 :child (make-instance 'v-box
1785 :homogeneous nil :spacing 10 :border-width 10
1786 :child close-button))
1789 (make-instance 'v-box
1790 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1791 :children (mapcar #'(lambda (spec)
1792 (apply #'create-button spec))
1794 (scrolled-window-add-with-viewport scrolled-window content-box))
1796 (widget-grab-focus close-button)
1797 (widget-show-all main-window)
1801 (create-main-window)