1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; Parts of this file are direct translations of code from 'testgtk.c'
24 ;; distributed with the Gtk+ library, and thus covered by the GNU
25 ;; Lesser General Public License and copyright Peter Mattis, Spencer
26 ;; Kimball, Josh MacDonald and others. To be safe the entire file
27 ;; should probably be considered as being GPL'ed.
30 ;; $Id: testgtk.lisp,v 1.44 2008-12-09 19:37:19 espen Exp $
33 #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
36 (:use "COMMON-LISP" "CLG"))
38 (in-package "TESTGTK")
40 (defmacro define-toplevel (name (window title &rest initargs) &body body)
44 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
45 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
49 (if (not (widget-visible-p ,window))
51 (widget-hide ,window))))))
54 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
60 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
61 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
65 (if (not (widget-visible-p ,dialog))
67 (widget-hide ,dialog))))))
70 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
71 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
73 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
77 ;;; Pixmaps used in some of the tests
119 (defvar book-closed-xpm
144 (defvar mini-page-xpm
167 (defvar book-open-xpm
194 (defun create-bbox-in-frame (class frame-label spacing width height layout)
195 (declare (ignore width height))
196 (make-instance 'frame
198 :child (make-instance class
199 :border-width 5 :layout-style layout :spacing spacing
200 :child (make-instance 'button :stock "gtk-ok")
201 :child (make-instance 'button :stock "gtk-cancel")
202 :child (make-instance 'button :stock "gtk-help"))))
204 (define-toplevel create-button-box (window "Button Boxes")
205 (make-instance 'v-box
206 :parent window :border-width 10 :spacing 10
207 :child (make-instance 'frame
208 :label "Horizontal Button Boxes"
209 :child (make-instance 'v-box
210 :border-width 10 :spacing 10
213 (apply #'create-bbox-in-frame
215 '(("Spread" 40 85 20 :spread)
216 ("Edge" 40 85 20 :edge)
217 ("Start" 40 85 20 :start)
218 ("End" 40 85 20 :end)))))
219 :child (make-instance 'frame
220 :label "Vertical Button Boxes"
221 :child (make-instance 'h-box
222 :border-width 10 :spacing 10
225 (apply #'create-bbox-in-frame
227 '(("Spread" 30 85 20 :spread)
228 ("Edge" 30 85 20 :edge)
229 ("Start" 30 85 20 :start)
230 ("End" 30 85 20 :end)))))))
235 (define-simple-dialog create-buttons (dialog "Buttons")
236 (let ((table (make-instance 'table
237 :n-rows 3 :n-columns 3 :homogeneous nil
238 :row-spacing 5 :column-spacing 5 :border-width 10
242 collect (make-instance 'button
243 :label (format nil "button~D" (1+ n))))))
247 (let ((button (nth (+ (* 3 row) column) buttons))
248 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
249 (signal-connect button 'clicked
251 (if (widget-visible-p button+1)
252 (widget-hide button+1)
253 (widget-show button+1))))
254 (table-attach table button column (1+ column) row (1+ row)
255 :options '(:expand :fill)))))))
260 (define-simple-dialog create-calendar (dialog "Calendar")
261 (make-instance 'v-box
262 :parent dialog :border-width 10
263 :child (make-instance 'calendar)))
268 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
269 (make-instance 'v-box
270 :border-width 10 :spacing 10 :parent dialog
273 collect (make-instance 'check-button
274 :label (format nil "Button~D" n)))))
280 (define-dialog create-color-selection (dialog "Color selection dialog"
281 'color-selection-dialog
282 :allow-grow nil :allow-shrink nil
284 (with-slots (colorsel) dialog
285 (let ((button (make-instance 'check-button :label "Show Opacity")))
286 (dialog-add-action-widget dialog button
289 (color-selection-has-opacity-control-p colorsel)
290 (toggle-button-active-p button)))))
292 (let ((button (make-instance 'check-button :label "Show Palette")))
293 (dialog-add-action-widget dialog button
296 (color-selection-has-palette-p colorsel)
297 (toggle-button-active-p button)))))
299 (signal-connect dialog :ok
301 (let ((color (color-selection-current-color colorsel)))
302 (format t "Selected color: ~A~%" color)
303 (setf (color-selection-current-color colorsel) color)
304 (widget-hide dialog))))
306 (signal-connect dialog :cancel #'widget-destroy :object t)))
309 ;;; Cursors (Note: using the drawing function in Gdk is considered
310 ;;; deprecated in clg, new code should use Cairo instead)
312 (defun clamp (n min-val max-val)
313 (declare (number n min-val max-val))
314 (max (min n max-val) min-val))
316 (defun set-cursor (spinner drawing-area label)
319 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
321 (setf (label-label label) (string-downcase cursor))
322 (widget-set-cursor drawing-area cursor)))
324 (defun cursor-expose (drawing-area event)
325 (declare (ignore event))
326 (multiple-value-bind (width height)
327 (widget-get-size-allocation drawing-area)
328 (let* ((window (widget-window drawing-area))
329 (style (widget-style drawing-area))
330 (white-gc (style-white-gc style))
331 (gray-gc (style-bg-gc style :normal))
332 (black-gc (style-black-gc style)))
333 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
334 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
336 (gdk:draw-rectangle window gray-gc t (floor width 3)
337 (floor height 3) (floor width 3)
341 (define-simple-dialog create-cursors (dialog "Cursors")
342 (let ((spinner (make-instance 'spin-button
343 :adjustment (adjustment-new
345 (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
347 (drawing-area (make-instance 'drawing-area
348 :width-request 80 :height-request 80
349 :events '(:exposure :button-press)))
350 (label (make-instance 'label :label "XXX")))
352 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
354 (signal-connect drawing-area 'button-press-event
356 (case (gdk:event-button event)
357 (1 (spin-button-spin spinner :step-forward))
358 (3 (spin-button-spin spinner :step-backward)))
361 (signal-connect drawing-area 'scroll-event
363 (case (gdk:event-direction event)
364 (:up (spin-button-spin spinner :step-forward))
365 (:down (spin-button-spin spinner :step-backward)))
368 (signal-connect spinner 'changed
370 (set-cursor spinner drawing-area label)))
372 (make-instance 'v-box
373 :parent dialog :border-width 10 :spacing 5
375 (make-instance 'h-box
378 (make-instance 'label :label "Cursor Value : ")
382 :child (make-instance 'frame
383 :label "Cursor Area" :label-xalign 0.5 :border-width 10
385 :child (list label :expand nil))
387 (widget-realize drawing-area)
388 (set-cursor spinner drawing-area label)))
394 (defun create-dialog ()
396 (setq dialog (make-instance 'dialog
397 :title "Dialog" :default-width 200
399 :button (list "gtk-ok" #'widget-destroy :object t)
400 :signal (list 'destroy
402 (setq dialog nil)))))
404 (let ((label (make-instance 'label
405 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
407 (signal-connect dialog "Toggle"
409 (if (widget-visible-p label)
411 (widget-show label))))))
413 (if (widget-visible-p dialog)
415 (widget-show dialog))))
420 (define-simple-dialog create-entry (dialog "Entry")
421 (let ((main (make-instance 'v-box
422 :border-width 10 :spacing 10 :parent dialog)))
424 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
425 (editable-select-region entry 0 5) ; this has no effect when
427 ;; (editable-insert-text entry "great " 6)
428 ;; (editable-delete-text entry 6 12)
430 (let ((combo (make-instance 'combo-box-entry
435 "item3 item3 item3 item3"
436 "item4 item4 item4 item4 item4"
437 "item5 item5 item5 item5 item5 item5"
438 "item6 item6 item6 item6 item6"
439 "item7 item7 item7 item7"
442 (with-slots (child) combo
443 (setf (editable-text child) "hello world")
444 (editable-select-region child 0)))
446 (flet ((create-check-button (label slot)
447 (make-instance 'check-button
448 :label label :active t :parent main
449 :signal (list 'toggled
451 (setf (slot-value entry slot)
452 (toggle-button-active-p button)))
455 (create-check-button "Editable" 'editable)
456 (create-check-button "Visible" 'visibility)
457 (create-check-button "Sensitive" 'sensitive)))))
462 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
463 (make-instance 'v-box
464 :parent dialog :spacing 5 :border-width 5
465 :child (create-label "Expander demo. Click on the triangle for details.")
466 :child (make-instance 'expander
468 :child (create-label "Details can be shown or hidden."))))
471 ;; File chooser dialog
473 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
474 (file-chooser-add-filter dialog
475 (make-instance 'file-filter :name "All files" :pattern "*"))
476 (file-chooser-add-filter dialog
477 (make-instance 'file-filter :name "Common Lisp source code"
478 :patterns '("*.lisp" "*.lsp")))
480 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
481 (dialog-add-button dialog "gtk-ok"
483 (if (slot-boundp dialog 'filename)
484 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
485 (write-line "No files selected"))
486 (widget-destroy dialog))))
489 ;; Font selection dialog
491 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
492 (make-instance 'h-box
493 :parent window :spacing 8 :border-width 8
494 :child (make-instance 'label :label "Pick a font")
495 :child (make-instance 'font-button
496 :use-font t :title "Font Selection Dialog")))
502 (defun get-directory-listing (directory)
503 (let ((dir #+cmu(unix:open-dir directory)
504 #+sbcl(sb-posix:opendir directory)))
507 as filename = #+cmu(unix:read-dir dir)
508 #+sbcl(let ((dirent (sb-posix:readdir dir)))
509 (unless (sb-grovel::foreign-nullp dirent)
510 (sb-posix:dirent-name dirent)))
512 collect (let* ((pathname (format nil "~A~A" directory filename))
514 #+cmu(eq (unix:unix-file-kind pathname) :directory)
515 #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
516 (list filename directory-p)))
517 #+cmu(unix:close-dir dir)
518 #+sbcl(sb-posix:closedir dir))))
521 (defun get-directory-listing (directory)
523 (mapcar #'(lambda (entry)
524 (let ((pathname (namestring (first entry))))
525 (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
526 (directory (format nil "~A*" directory) :full t))
527 (mapcar #'(lambda (entry)
528 (let ((pathname (namestring entry)))
529 (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
531 (directory (format nil "~A*/" directory)))))
534 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
535 (let ((file-pixbuf nil)
537 (defun load-pixbufs ()
541 file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
542 folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
543 (glib:glib-error (condition)
544 (make-instance 'message-dialog
545 :message-type :error :visible t
546 :text "<b>Failed to load an image</b>"
547 :secondary-text (glib:gerror-message condition)
548 :signal (list :ok #'widget-destroy :object t))
549 (return-from load-pixbufs nil))))
552 (defun fill-store (store directory)
553 (list-store-clear store)
555 for (filename directory-p) in (get-directory-listing directory)
556 unless (or (string= filename ".") (string= filename ".."))
557 do (list-store-insert store 0
560 (if directory-p folder-pixbuf file-pixbuf)
563 (defun sort-func (store a b)
564 (let ((a-dir-p (tree-model-value store a 'directory-p))
565 (b-dir-p (tree-model-value store b 'directory-p))
566 (a-name (tree-model-value store a 'filename))
567 (b-name (tree-model-value store b 'filename)))
569 ((and a-dir-p (not b-dir-p)) :before)
570 ((and (not a-dir-p) b-dir-p) :after)
571 ((string< a-name b-name) :before)
572 ((string> a-name b-name) :after)
576 (defun parent-dir (dir)
577 (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
580 (define-toplevel create-icon-view (window "Icon View demo"
583 (if (not (load-pixbufs))
584 (widget-destroy window)
585 (let* ((directory "/")
586 (store (make-instance 'list-store
587 :column-types '(string gdk:pixbuf boolean)
588 :column-names '(filename pixbuf directory-p)))
589 (icon-view (make-instance 'icon-view
590 :model store :selection-mode :multiple
591 :text-column 'filename
592 :pixbuf-column 'pixbuf))
593 (up (make-instance 'tool-button
594 :stock "gtk-go-up" :is-important t :sensitive nil))
595 (home (make-instance 'tool-button
596 :stock "gtk-home" :is-important t)))
597 (tree-sortable-set-sort-func store :default #'sort-func)
598 (tree-sortable-set-sort-column store :default :ascending)
599 (fill-store store directory)
601 (signal-connect icon-view 'item-activated
603 (when (tree-model-value store path 'directory-p)
605 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
606 (fill-store store directory)
607 (setf (widget-sensitive-p up) t))))
609 (signal-connect up 'clicked
611 (unless (string= directory "/")
612 (setq directory (parent-dir directory))
613 (fill-store store directory)
615 (widget-sensitive-p home)
616 (not (string= directory (namestring (truename #p"clg:")))))
617 (setf (widget-sensitive-p up) (not (string= directory "/"))))))
619 (signal-connect home 'clicked
621 (setq directory (namestring (truename #p"clg:")))
622 (fill-store store directory)
623 (setf (widget-sensitive-p up) t)
624 (setf (widget-sensitive-p home) nil)))
626 (make-instance 'v-box
629 (make-instance 'toolbar :child up :child home)
630 :fill nil :expand nil)
631 :child (make-instance 'scrolled-window
632 :shadow-type :etched-in :policy :automatic
633 :child icon-view))))))
638 (define-toplevel create-image (window "Image" :resizable nil)
639 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
644 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
645 (flet ((create-label-in-frame (frame-label label-text &rest args)
646 (make-instance 'frame
648 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
649 (make-instance 'h-box
650 :spacing 5 :parent window
651 :child-args '(:fill nil :expand nil)
652 :child (make-instance 'v-box
653 :spacing 5 :child-args '(:fill nil :expand nil)
654 :child (create-label-in-frame "Normal Label" "This is a Normal label")
655 :child (create-label-in-frame "Multi-line Label"
656 "This is a Multi-line label.
659 :child (create-label-in-frame "Left Justified Label"
660 "This is a Left-Justified
664 :child (create-label-in-frame "Right Justified Label"
665 "This is a Right-Justified
669 :child (make-instance 'v-box
670 :spacing 5 :child-args '(:fill nil :expand nil)
671 :child (create-label-in-frame "Line wrapped label"
672 "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.
673 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
676 :child (create-label-in-frame "Filled, wrapped label"
677 "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.
678 This is a new paragraph.
679 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
680 :justify :fill :wrap t)
682 :child (create-label-in-frame "Underlined label"
683 "This label is underlined!
684 This one is underlined in quite a funky fashion"
686 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
689 ;;; Layout (Note: using the drawing function in Gdk is considered
690 ;;; deprecated in clg, new code should use Cairo instead)
692 (defun layout-expose (layout event)
693 (when (eq (gdk:event-window event) (layout-bin-window layout))
694 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
695 (let ((imin (truncate gdk:x 10))
696 (imax (truncate (+ gdk:x gdk:width 9) 10))
697 (jmin (truncate gdk:y 10))
698 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
700 (let ((window (layout-bin-window layout))
701 (gc (style-black-gc (widget-style layout))))
703 for i from imin below imax
705 for j from jmin below jmax
706 unless (zerop (mod (+ i j) 2))
707 do (gdk:draw-rectangle
708 window gc t (* 10 i) (* 10 j)
709 (1+ (mod i 10)) (1+ (mod j 10)))))))))
712 (define-toplevel create-layout (window "Layout" :default-width 200
714 (let ((layout (make-instance 'layout
715 :parent (make-instance 'scrolled-window :parent window)
716 :width 1600 :height 128000 :events '(:exposure)
717 :signal (list 'expose-event #'layout-expose :object t))))
719 (with-slots (hadjustment vadjustment) layout
721 (adjustment-step-increment hadjustment) 10.0
722 (adjustment-step-increment vadjustment) 10.0))
726 (let ((text (format nil "Button ~D, ~D" i j)))
728 (make-instance (if (not (zerop (mod (+ i j) 2)))
731 :label text :visible t)
732 (* j 100) (* i 100)))))
735 for i from 16 below 1280
736 do (let ((text (format nil "Button ~D, ~D" i 0)))
738 (make-instance (if (not (zerop (mod i 2)))
741 :label text :visible t)
748 (define-simple-dialog create-list (dialog "List" :default-height 400)
749 (let* ((store (make-instance 'list-store
750 :column-types '(string integer boolean)
751 :column-names '(:foo :bar :baz)
752 :initial-content '(#("First" 12321 nil)
753 (:foo "Yeah" :baz t))))
754 (tree (make-instance 'tree-view :model store)))
757 with iter = (make-instance 'tree-iter)
759 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
761 (let ((column (make-instance 'tree-view-column :title "Column 1"))
762 (cell (make-instance 'cell-renderer-text)))
763 (cell-layout-pack column cell :expand t)
764 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
765 (tree-view-append-column tree column))
767 (let ((column (make-instance 'tree-view-column :title "Column 2"))
768 (cell (make-instance 'cell-renderer-text :background "orange")))
769 (cell-layout-pack column cell :expand t)
770 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
771 (tree-view-append-column tree column))
773 (let ((column (make-instance 'tree-view-column :title "Column 3"))
774 (cell (make-instance 'cell-renderer-text)))
775 (cell-layout-pack column cell :expand t)
776 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
777 (tree-view-append-column tree column))
779 (make-instance 'v-box
780 :parent dialog :border-width 10 :spacing 10
782 (make-instance 'h-box
784 :child (make-instance 'button
785 :label "Remove Selection"
786 :signal (list 'clicked
791 (make-instance 'tree-row-reference :model store :path path))
792 (tree-selection-get-selected-rows
793 (tree-view-selection tree)))))
795 #'(lambda (reference)
796 (list-store-remove store reference))
800 (make-instance 'h-box
802 :child (make-instance 'check-button
803 :label "Show Headers" :active t
804 :signal (list 'toggled
807 (tree-view-headers-visible-p tree)
808 (toggle-button-active-p button)))
810 :child (make-instance 'check-button
811 :label "Reorderable" :active nil
812 :signal (list 'toggled
815 (tree-view-reorderable-p tree)
816 (toggle-button-active-p button)))
819 (make-instance 'h-box
820 :child (make-instance 'label :label "Selection Mode: ")
821 :child (make-instance 'combo-box
822 :content '("Single" "Browse" "Multiple")
824 :signal (list 'changed
825 #'(lambda (combo-box)
828 (tree-view-selection tree))
830 #(:single :browse :multiple)
831 (combo-box-active combo-box))))
835 :child (make-instance 'scrolled-window
836 :child tree :hscrollbar-policy :automatic))))
841 (defun create-menu (depth tearoff)
842 (unless (zerop depth)
843 (let ((menu (make-instance 'menu)))
845 (let ((menu-item (make-instance 'tearoff-menu-item)))
846 (menu-shell-append menu menu-item)))
850 (make-instance 'radio-menu-item
851 :label (format nil "item ~2D - ~D" depth (1+ i)))))
853 (add-to-radio-group menu-item group)
854 (setq group menu-item))
855 (unless (zerop (mod depth 2))
856 (setf (check-menu-item-active-p menu-item) t))
857 (menu-shell-append menu menu-item)
859 (setf (widget-sensitive-p menu-item) nil))
860 (let ((submenu (create-menu (1- depth) t)))
862 (setf (menu-item-submenu menu-item) submenu))))))
866 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
867 (let* ((main (make-instance 'v-box :parent dialog))
868 ; (accel-group (make-instance 'accel-group))
869 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
870 ; (window-add-accel-group dialog accel-group)
872 (let ((menu-item (make-instance 'menu-item
873 :label (format nil "test~%line2"))))
874 (setf (menu-item-submenu menu-item) (create-menu 2 t))
875 (menu-shell-append menubar menu-item))
877 (let ((menu-item (make-instance 'menu-item :label "foo")))
878 (setf (menu-item-submenu menu-item) (create-menu 3 t))
879 (menu-shell-append menubar menu-item))
881 (let ((menu-item (make-instance 'menu-item :label "bar")))
882 (setf (menu-item-submenu menu-item) (create-menu 4 t))
883 (setf (menu-item-right-justified-p menu-item) t)
884 (menu-shell-append menubar menu-item))
886 (make-instance 'v-box
887 :spacing 10 :border-width 10 :parent main
888 :child (make-instance 'combo-box
892 collect (format nil "Item ~D" i))))
894 (widget-show-all main)))
899 (defun create-notebook-page (notebook page-num book-closed)
900 (let* ((title (format nil "Page ~D" page-num))
901 (page (make-instance 'frame :label title :border-width 10))
902 (v-box (make-instance 'v-box
903 :homogeneous t :border-width 10 :parent page)))
905 (make-instance 'h-box
906 :parent (list v-box :fill nil :padding 5) :homogeneous t
907 :child-args '(:padding 5)
908 :child (make-instance 'check-button
909 :label "Fill Tab" :active t
910 :signal (list 'toggled
913 (notebook-child-tab-fill-p page)
914 (toggle-button-active-p button)))
916 :child (make-instance 'check-button
918 :signal (list 'toggled
921 (notebook-child-tab-expand-p page)
922 (toggle-button-active-p button)))
924 :child (make-instance 'check-button
926 :signal (list 'toggled
929 (notebook-child-tab-pack page)
930 (if (toggle-button-active-p button)
934 :child (make-instance 'button
936 :signal (list 'clicked #'(lambda () (widget-hide page)))))
939 (let ((label-box (make-instance 'h-box
941 :child-args '(:expand nil)
942 :child (make-instance 'image :pixbuf book-closed)
943 :child (make-instance 'label :label title)))
944 (menu-box (make-instance 'h-box
946 :child-args '(:expand nil)
947 :child (make-instance 'image :pixbuf book-closed)
948 :child (make-instance 'label :label title))))
950 (notebook-append notebook page label-box menu-box))))
952 (define-simple-dialog create-notebook (dialog "Notebook")
953 (let ((main (make-instance 'v-box :parent dialog)))
954 (let ((book-open (make-instance 'gdk:pixbuf :source book-open-xpm))
955 (book-closed (make-instance 'gdk:pixbuf :source book-closed-xpm))
956 (notebook (make-instance 'notebook
957 :border-width 10 :tab-pos :top :parent main)))
959 (flet ((set-image (page func pixbuf)
962 (first (container-children (funcall func notebook page))))
964 (signal-connect notebook 'switch-page
965 #'(lambda (pointer page)
966 (declare (ignore pointer))
967 (set-image page #'notebook-menu-label book-open)
968 (set-image page #'notebook-tab-label book-open)
969 (when (slot-boundp notebook 'current-page)
970 (let ((curpage (notebook-current-page notebook)))
971 (set-image curpage #'notebook-menu-label book-closed)
972 (set-image curpage #'notebook-tab-label book-closed))))))
973 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
975 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
977 (make-instance 'h-box
978 :spacing 5 :border-width 10
979 :parent (list main :expand nil)
980 :child-args '(:fill nil)
981 :child (make-instance 'check-button
983 :signal (list 'clicked
985 (if (toggle-button-active-p button)
986 (notebook-popup-enable notebook)
987 (notebook-popup-disable notebook)))
989 :child (make-instance 'check-button
990 :label "Homogeneous tabs"
991 :signal (list 'clicked
994 (notebook-homogeneous-p notebook)
995 (toggle-button-active-p button)))
998 (make-instance 'h-box
999 :spacing 5 :border-width 10
1000 :parent (list main :expand nil)
1001 :child-args '(:expand nil)
1002 :child (make-instance 'label :label "Notebook Style: ")
1003 :child (let ((scrollable-p nil))
1004 (make-instance 'combo-box
1005 :content '("Standard" "No tabs" "Scrollable") :active 0
1006 :signal (list 'changed
1007 #'(lambda (combo-box)
1008 (case (combo-box-active combo-box)
1010 (setf (notebook-show-tabs-p notebook) t)
1012 (setq scrollable-p nil)
1013 (setf (notebook-scrollable-p notebook) nil)
1015 do (notebook-remove-page notebook 5))))
1017 (setf (notebook-show-tabs-p notebook) nil)
1019 (setq scrollable-p nil)
1020 (setf (notebook-scrollable-p notebook) nil)
1022 do (notebook-remove-page notebook 5))))
1024 (unless scrollable-p
1025 (setq scrollable-p t)
1026 (setf (notebook-show-tabs-p notebook) t)
1027 (setf (notebook-scrollable-p notebook) t)
1028 (loop for i from 6 to 15
1029 do (create-notebook-page notebook i book-closed))))))
1031 :child (make-instance 'button
1032 :label "Show all Pages"
1033 :signal (list 'clicked
1035 (map-container nil #'widget-show notebook)))))
1037 (make-instance 'h-box
1038 :spacing 5 :border-width 10
1039 :parent (list main :expand nil)
1040 :child (make-instance 'button
1042 :signal (list 'clicked #'notebook-prev-page :object notebook))
1043 :child (make-instance 'button
1045 :signal (list 'clicked #'notebook-next-page :object notebook))
1046 :child (make-instance 'button
1048 :signal (let ((tab-pos 0))
1051 (setq tab-pos (mod (1+ tab-pos) 4))
1053 (notebook-tab-pos notebook)
1054 (svref #(:top :right :bottom :left) tab-pos))))))))
1055 (widget-show-all main)))
1061 (defun toggle-resize (child)
1062 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1064 (defun toggle-shrink (child)
1065 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1067 (defun create-pane-options (paned frame-label label1 label2)
1068 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1069 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1070 (let ((check-button (make-instance 'check-button :label "Resize")))
1071 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1072 (signal-connect check-button 'toggled
1073 #'toggle-resize :object (paned-child1 paned)))
1074 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1075 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1076 (signal-connect check-button 'toggled
1077 #'toggle-shrink :object (paned-child1 paned)))
1079 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1080 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1081 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1082 (signal-connect check-button 'toggled
1083 #'toggle-resize :object (paned-child2 paned)))
1084 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1085 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1086 (signal-connect check-button 'toggled
1087 #'toggle-shrink :object (paned-child2 paned)))
1088 (make-instance 'frame :label frame-label :border-width 4 :child table)))
1090 (define-toplevel create-panes (window "Panes")
1091 (let* ((hpaned (make-instance 'h-paned
1092 :child1 (make-instance 'frame
1093 :width-request 60 :height-request 60
1095 :child (make-instance 'button :label "Hi there"))
1096 :child2 (make-instance 'frame
1097 :width-request 80 :height-request 60
1099 (vpaned (make-instance 'v-paned
1102 :child2 (make-instance 'frame
1103 :width-request 80 :height-request 60
1104 :shadow-type :in))))
1106 (make-instance 'v-box
1108 :child-args '(:expand nil)
1109 :child (list vpaned :expand t)
1110 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1111 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1116 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1117 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1118 (activity-mode-button (make-instance 'check-button
1119 :label "Activity mode"))
1120 (timer (timeout-add 100
1122 (if (toggle-button-active-p activity-mode-button)
1123 (progress-bar-pulse progress)
1124 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1126 (progress-bar-fraction progress)
1132 (make-instance 'v-box
1133 :parent dialog :border-width 10 :spacing 10
1135 :child activity-mode-button)
1137 (signal-connect dialog 'destroy
1138 #'(lambda () (when timer (timeout-remove timer))))))
1143 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1144 (make-instance 'v-box
1145 :parent dialog :border-width 10 :spacing 10
1146 :children (make-radio-group 'radio-button
1147 '((:label "button1") (:label "button2") (:label "button3"))
1153 (define-simple-dialog create-range-controls (dialog "Range controls")
1154 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1155 (make-instance 'v-box
1156 :parent dialog :border-width 10 :spacing 10
1157 :child (make-instance 'h-scale
1158 :width-request 150 :adjustment adjustment :inverted t
1159 :update-policy :delayed :digits 1 :draw-value t)
1160 :child (make-instance 'h-scrollbar
1161 :adjustment adjustment :update-policy :continuous))))
1166 (define-simple-dialog create-reparent (dialog "Reparent")
1167 (let ((main (make-instance 'h-box
1168 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1169 (label (make-instance 'label :label "Hello World")))
1171 (flet ((create-frame (title)
1172 (let* ((frame (make-instance 'frame :label title :parent main))
1173 (box (make-instance 'v-box
1174 :spacing 5 :border-width 5 :parent frame))
1175 (button (make-instance 'button
1176 :label "switch" :parent (list box :expand nil))))
1177 (signal-connect button 'clicked
1179 (widget-reparent label box)))
1182 (box-pack-start (create-frame "Frame 1") label nil t 0)
1183 (create-frame "Frame 2"))
1184 (widget-show-all main)))
1189 (define-toplevel create-rulers (window "Rulers"
1190 :default-width 300 :default-height 300
1191 :events '(:pointer-motion :pointer-motion-hint))
1192 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1193 (h-ruler (make-instance 'h-ruler
1194 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1195 :position 0.0d0 :max-size 20.0d0))
1196 (v-ruler (make-instance 'v-ruler
1197 :lower 5.0d0 :upper 15.0d0
1198 :position 0.0d0 :max-size 20.0d0)))
1199 (signal-connect window 'motion-notify-event
1201 (widget-event h-ruler event)
1202 (widget-event v-ruler event)))
1203 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1204 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1209 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1211 :default-height 300)
1212 (let* ((scrolled-window
1213 (make-instance 'scrolled-window
1214 :parent dialog :border-width 10
1215 :vscrollbar-policy :automatic
1216 :hscrollbar-policy :automatic))
1218 (make-instance 'table
1219 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1220 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1221 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1223 (scrolled-window-add-with-viewport scrolled-window table)
1227 (make-instance 'toggle-button
1228 :label (format nil "button (~D,~D)~%" i j))))
1229 (table-attach table button i (1+ i) j (1+ j)))))
1230 (widget-show-all scrolled-window)))
1235 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1236 (let ((size-group (make-instance 'size-group)))
1237 (flet ((create-frame (label rows)
1238 (let ((table (make-instance 'table
1239 :n-rows (length rows) :n-columns 2 :homogeneous nil
1240 :row-spacing 5 :column-spacing 10 :border-width 5)))
1244 do (table-attach table
1245 (create-label (first row) :xalign 0 :yalign 1)
1246 0 1 i (1+ i) :x-options '(:expand :fill))
1247 (let ((combo (make-instance 'combo-box
1248 :content (rest row) :active 0)))
1249 (size-group-add-widget size-group combo)
1250 (table-attach table combo 1 2 i (1+ i))))
1251 (make-instance 'frame :label label :child table))))
1253 (make-instance 'v-box
1254 :parent dialog :border-width 5 :spacing 5
1255 :child (create-frame "Color Options"
1256 '(("Foreground" "Red" "Green" "Blue")
1257 ("Background" "Red" "Green" "Blue")))
1258 :child (create-frame "Line Options"
1259 '(("Dashing" "Solid" "Dashed" "Dotted")
1260 ("Line ends" "Square" "Round" "Arrow")))
1261 :child (create-check-button "Enable grouping"
1264 (size-group-mode size-group)
1265 (if active :horizontal :none)))
1271 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1273 (make-instance 'window
1274 :type type :default-width 100 :default-height 100
1275 :events '(:button-motion :pointer-motion-hint :button-press)
1276 :signal (list 'destroy destroy))))
1278 (widget-realize window)
1279 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1280 (let ((fixed (make-instance 'fixed :parent window)))
1281 (fixed-put fixed (create-image-widget source mask) px py))
1282 (widget-shape-combine-mask window mask px py))
1286 (declare (fixnum x-offset y-offset))
1287 (signal-connect window 'button-press-event
1289 (when (typep event 'gdk:button-press-event)
1290 (setq x-offset (truncate (gdk:event-x event)))
1291 (setq y-offset (truncate (gdk:event-y event)))
1293 (gdk:pointer-grab (widget-window window)
1294 :events '(:button-release :button-motion :pointer-motion-hint)
1297 (signal-connect window 'button-release-event
1299 (declare (ignore event))
1300 (grab-remove window)
1301 (gdk:pointer-ungrab)))
1303 (signal-connect window 'motion-notify-event
1305 (declare (ignore event))
1306 (multiple-value-bind (win xp yp mask)
1307 (gdk:window-get-pointer root-window)
1308 (declare (ignore mask win) (fixnum xp yp))
1309 (window-move window (- xp x-offset) (- yp y-offset))))))
1311 (window-move window x y)
1312 (widget-show-all window)
1316 (let ((modeller nil)
1319 (defun create-shapes ()
1320 (let ((root-window (gdk:get-root-window)))
1325 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1326 #'(lambda () (setq modeller nil))))
1327 (widget-destroy modeller))
1333 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1334 #'(lambda () (setq sheets nil))))
1335 (widget-destroy sheets))
1341 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1342 #'(lambda () (setq rings nil))))
1343 (widget-destroy rings)))))
1349 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1350 (let ((main (make-instance 'v-box
1351 :spacing 5 :border-width 10 :parent dialog)))
1353 (flet ((create-date-spinner (label adjustment shadow-type)
1354 (declare (ignore shadow-type))
1355 (make-instance 'v-box
1356 :child-args '(:expand nil)
1357 :child (make-instance 'label
1358 :label label :xalign 0.0 :yalign 0.5)
1359 :child (make-instance 'spin-button
1360 :adjustment adjustment :wrap t))))
1361 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1363 (declare (ignore sec min hour day daylight-p zone))
1364 (make-instance 'frame
1365 :label "Not accelerated" :parent main
1366 :child (make-instance 'h-box
1368 :child-args '(:padding 5)
1369 :child (create-date-spinner "Day : "
1370 (adjustment-new date 1 31 1 5 0) :out)
1371 :child (create-date-spinner "Month : "
1372 (adjustment-new month 1 12 1 5 0) :etched-in)
1373 :child (create-date-spinner "Year : "
1374 (adjustment-new year 0 2100 1 100 0) :in)))))
1376 (let ((spinner1 (make-instance 'spin-button
1377 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1378 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1379 (spinner2 (make-instance 'spin-button
1380 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1381 :climb-rate 1.0 :wrap t))
1382 (value-label (make-instance 'label :label "0")))
1383 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1386 (spin-button-digits spinner1)
1387 (floor (spin-button-value spinner2)))))
1389 (make-instance 'frame
1390 :label "Accelerated" :parent main
1391 :child (make-instance 'v-box
1394 (make-instance 'h-box
1395 :child-args '(:padding 5)
1396 :child (make-instance 'v-box
1397 :child (make-instance 'label
1399 :xalign 0.0 :yalign 0.5)
1401 :child (make-instance 'v-box
1402 :child (make-instance 'label
1404 :xalign 0.0 :yalign 0.5)
1406 :expand nil :padding 5)
1407 :child (make-instance 'check-button
1408 :label "Snap to 0.5-ticks" :active t
1409 :signal (list 'clicked
1412 (spin-button-snap-to-ticks-p spinner1)
1413 (toggle-button-active-p button)))
1415 :child (make-instance 'check-button
1416 :label "Numeric only input mode" :active t
1417 :signal (list 'clicked
1420 (spin-button-numeric-p spinner1)
1421 (toggle-button-active-p button)))
1425 (make-instance 'h-box
1426 :child-args '(:padding 5)
1427 :child (make-instance 'button
1428 :label "Value as Int"
1429 :signal (list 'clicked
1432 (label-label value-label)
1434 (spin-button-value-as-int
1436 :child (make-instance 'button
1437 :label "Value as Float"
1438 :signal (list 'clicked
1441 (label-label value-label)
1443 (format nil "~~,~DF"
1444 (spin-button-digits spinner1))
1445 (spin-button-value spinner1)))))))
1446 :padding 5 :expand nil))))
1447 (widget-show-all main)))
1452 (define-toplevel create-statusbar (window "Statusbar")
1453 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1454 (close-button (create-button '("close" :can-default t)
1455 #'widget-destroy :object window))
1458 (signal-connect statusbar 'text-popped
1459 #'(lambda (context-id text)
1460 (declare (ignore context-id))
1461 (format nil "Popped: ~A~%" text)))
1463 (make-instance 'v-box
1465 :child (make-instance 'v-box
1466 :border-width 10 :spacing 10
1467 :child (create-button "push something"
1469 (statusbar-push statusbar 1
1470 (format nil "something ~D" (incf counter)))))
1471 :child (create-button "pop"
1473 (statusbar-pop statusbar 1)))
1474 :child (create-button "steal #4"
1476 (statusbar-remove statusbar 1 4)))
1477 :child (create-button "dump stack")
1478 :child (create-button "test contexts"))
1479 :child (list (make-instance 'h-separator) :expand nil)
1481 (make-instance 'v-box :border-width 10 :child close-button)
1483 :child (list statusbar :expand nil))
1485 (widget-grab-focus close-button)))
1490 (define-simple-dialog create-idle-test (dialog "Idle Test")
1491 (let ((label (make-instance 'label
1492 :label "count: 0" :xpad 10 :ypad 10))
1495 (signal-connect dialog 'destroy
1496 #'(lambda () (when idle (idle-remove idle))))
1498 (make-instance 'v-box
1499 :parent dialog :border-width 10 :spacing 10
1501 :child (make-instance 'frame
1502 :label "Label Container" :border-width 5
1503 :child(make-instance 'v-box
1504 :children (make-radio-group 'radio-button
1505 '((:label "Resize-Parent" :value :parent :active t)
1506 (:label "Resize-Queue" :value :queue)
1507 (:label "Resize-Immediate" :value :immediate))
1510 (container-resize-mode (dialog-action-area dialog)) mode))))))
1512 (dialog-add-button dialog "Start"
1519 (setf (label-label label) (format nil "count: ~D" count))
1522 (dialog-add-button dialog "Stop"
1526 (setq idle nil))))))
1532 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1533 (let ((label (make-instance 'label
1534 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1537 (signal-connect dialog 'destroy
1538 #'(lambda () (when timer (timeout-remove timer))))
1540 (dialog-add-button dialog "Start"
1547 (setf (label-label label) (format nil "count: ~D" count))
1550 (dialog-add-button dialog "Stop"
1553 (timeout-remove timer)
1554 (setq timer nil))))))
1559 (define-simple-dialog create-text (dialog "Text" :default-width 400
1560 :default-height 400)
1561 (let* ((text-view (make-instance 'text-view
1562 :border-width 10 :visible t :wrap-mode :word))
1563 (buffer (text-view-buffer text-view))
1566 (text-buffer-create-tag buffer "Bold" :weight :bold)
1567 (text-buffer-create-tag buffer "Italic" :style :italic)
1568 (text-buffer-create-tag buffer "Underline" :underline :single)
1570 (flet ((create-toggle-callback (tag-name)
1571 (let ((tag (text-tag-table-lookup
1572 (text-buffer-tag-table buffer) tag-name)))
1574 (unless (eq (and (find tag active-tags) t) active)
1577 (push tag active-tags)
1578 (setq active-tags (delete tag active-tags)))
1579 (multiple-value-bind (non-zero-p start end)
1580 (text-buffer-get-selection-bounds buffer)
1581 (declare (ignore non-zero-p))
1583 (text-buffer-apply-tag buffer tag start end)
1584 (text-buffer-remove-tag buffer tag start end))))))))
1587 (make-instance 'action-group
1588 :action (make-instance 'toggle-action
1589 :name "Bold" :stock-id "gtk-bold" :label "Bold"
1590 :accelerator "<control>B" :tooltip "Bold"
1591 :callback (create-toggle-callback "Bold"))
1592 :action (make-instance 'toggle-action
1593 :name "Italic" :stock-id "gtk-italic" :label "Italic"
1594 :accelerator "<control>I" :tooltip "Italic"
1595 :callback (create-toggle-callback "Italic"))
1596 :action (make-instance 'toggle-action
1597 :name "Underline" :stock-id "gtk-underline"
1598 :label "Underline" :accelerator "<control>U"
1599 :tooltip "Underline"
1600 :callback (create-toggle-callback "Underline"))))
1601 (ui (make-instance 'ui-manager
1602 :action-group actions
1603 :ui '((:toolbar "ToolBar"
1605 (:toolitem "Italic")
1606 (:toolitem "Underline"))))))
1608 ;; Callback to activate/deactivate toolbar buttons when cursor
1610 (signal-connect buffer 'mark-set
1611 #'(lambda (location mark)
1612 (declare (ignore mark))
1613 (text-tag-table-foreach (text-buffer-tag-table buffer)
1618 (text-iter-has-tag-p location tag)
1619 (not (text-iter-begins-tag-p location tag)))
1620 (text-iter-ends-tag-p location tag))))
1621 (unless (eq active (and (find tag active-tags) t))
1623 (push tag active-tags)
1624 (setq active-tags (delete tag active-tags)))
1626 (toggle-action-active-p
1627 (action-group-get-action actions (text-tag-name tag)))
1630 ;; Callback to apply active tags when a character is inserted
1631 (signal-connect buffer 'insert-text
1632 #'(lambda (iter &rest args)
1633 (declare (ignore args))
1634 (let ((before (text-buffer-get-iter-at-offset buffer
1635 (1- (text-iter-offset iter)))))
1637 for tag in active-tags
1638 do (text-buffer-apply-tag buffer tag before iter))))
1641 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1642 (container-add dialog text-view)
1644 (let ((position (make-instance 'label :visible t)))
1645 (flet ((update-position (line column)
1647 (label-label position)
1648 (format nil "Cursor Position: ~d,~d" (1+ line) column))))
1649 (update-position 0 0)
1651 ;; Callback to display current position when cursor is moved
1652 (signal-connect buffer 'mark-set
1653 #'(lambda (iter mark)
1655 (slot-boundp mark 'name)
1656 (string= (text-mark-name mark) "insert"))
1658 (text-iter-line iter) (text-iter-line-offset iter)))))
1660 ;; Callback to display current position after the
1661 ;; buffer has been modified
1662 (signal-connect buffer 'changed
1664 (let ((iter (text-buffer-get-iter-at-insert buffer)))
1666 (text-iter-line iter) (text-iter-line-offset iter))))
1669 (container-add dialog position :expand nil))))))
1674 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1675 (make-instance 'v-box
1676 :border-width 10 :spacing 10 :parent dialog
1679 collect (make-instance 'toggle-button
1680 :label (format nil "Button~D" (1+ n))))))
1686 (defun create-toolbar (window)
1687 (make-instance 'toolbar
1688 :show-tooltips t :show-arrow nil
1690 ;; Insert a stock item
1691 :child (make-instance 'tool-button
1693 :tip-text "Destroy toolbar"
1694 :tip-private "Toolbar/Quit"
1695 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1697 :child (make-instance 'separator-tool-item)
1699 :child (make-instance 'tool-button
1700 :label "Horizontal" :stock "gtk-go-forward"
1701 :tip-text "Horizontal toolbar layout"
1702 :tip-private "Toolbar/Horizontal"
1703 :signal (list 'clicked
1705 (setf (toolbar-orientation toolbar) :horizontal))
1708 :child (make-instance 'tool-button
1709 :label "Vertical" :stock "gtk-go-down"
1710 :tip-text "Vertical toolbar layout"
1711 :tip-private "Toolbar/Vertical"
1712 :signal (list 'clicked
1714 (setf (toolbar-orientation toolbar) :vertical))
1717 :child (make-instance 'separator-tool-item)
1719 :children (make-radio-group 'radio-tool-button
1720 '((:label "Icons" :stock "gtk-justify-left"
1721 :tip-text "Only show toolbar icons"
1722 :tip-private "Toolbar/IconsOnly"
1724 (:label "Both" :stock "gtk-justify-center"
1725 :tip-text "Show toolbar icons and text"
1726 :tip-private "Toolbar/Both"
1727 :value :both :active t)
1728 (:label "Text" :stock "gtk-justify-right"
1729 :tip-text "Show toolbar text"
1730 :tip-private "Toolbar/TextOnly"
1733 #'(lambda (toolbar style)
1734 (setf (toolbar-style toolbar) style))
1737 :child (make-instance 'separator-tool-item)
1739 :child (make-instance 'tool-item
1740 :child (make-instance 'entry)
1741 :tip-text "This is an unusable GtkEntry"
1742 :tip-private "Hey don't click me!")
1744 :child (make-instance 'separator-tool-item)
1746 :child (make-instance 'tool-button
1747 :label "Enable" :stock "gtk-add"
1748 :tip-text "Enable tooltips"
1749 :tip-private "Toolbar/EnableTooltips"
1750 :signal (list 'clicked
1752 (setf (toolbar-show-tooltips-p toolbar) t))
1755 :child (make-instance 'tool-button
1756 :label "Disable" :stock "gtk-remove"
1757 :tip-text "Disable tooltips"
1758 :tip-private "Toolbar/DisableTooltips"
1759 :signal (list 'clicked
1761 (setf (toolbar-show-tooltips-p toolbar) nil))
1764 ;; :child (make-instance 'separator-tool-item)
1766 ;; :child (make-instance 'tool-button
1767 ;; :label "GTK" :icon #p"clg:examples;gtk.png"
1768 ;; :tip-text "GTK+ Logo"
1769 ;; :tip-private "Toolbar/GTK+")
1772 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1773 (container-add window (create-toolbar window)))
1778 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1779 (make-instance 'v-box
1781 :child (create-label "Above")
1782 :child (make-instance 'h-separator)
1783 :child (make-instance 'h-box
1786 (make-instance 'handle-box
1787 :child (create-toolbar window)
1788 :signal (list 'child-attached
1790 (format t "~A attached~%" child)))
1791 :signal (list 'child-detached
1793 (format t "~A detached~%" child))))
1794 :expand nil :fill :nil))
1795 :child (make-instance 'h-separator)
1796 :child (create-label "Below")))
1799 ;;; Tooltips test. Note that GtkTooltips has been deprecated in GTK+ 2.12
1801 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1802 (let ((tooltips (make-instance 'tooltips)))
1803 (flet ((create-button (label tip-text tip-private)
1804 (let ((button (make-instance 'toggle-button :label label)))
1805 (tooltips-set-tip tooltips button tip-text tip-private)
1807 (make-instance 'v-box
1808 :parent dialog :border-width 10 :spacing 10
1809 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1810 :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
1815 (defvar *ui-description*
1816 '((:menubar "MenuBar"
1821 (:menuitem "SaveAs")
1824 (:menu "PreferencesMenu"
1830 (:menuitem "Square")
1831 (:menuitem "Rectangle")
1835 (:menuitem "About")))
1840 (:toolitem "Logo"))))
1842 (define-toplevel create-ui-manager (window "UI Manager")
1843 (let ((ui (make-instance 'ui-manager)))
1844 (window-add-accel-group window (ui-manager-accel-group ui))
1845 (ui-manager-insert-action-group ui
1846 (make-instance 'action-group :name "Actions"
1847 :action (make-instance 'action :name "FileMenu" :label "_File")
1848 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1849 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1850 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1851 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1852 :action (make-instance 'action
1853 :name "New" :stock-id "gtk-new" :label "_New"
1854 :accelerator "<control>N" :tooltip "Create a new file")
1855 :action (make-instance 'action
1856 :name "Open" :stock-id "gtk-open" :label "_Open"
1857 :accelerator "<control>O" :tooltip "Open a file"
1858 :callback #'create-file-chooser)
1859 :action (make-instance 'action
1860 :name "Save" :stock-id "gtk-save" :label "_Save"
1861 :accelerator "<control>S" :tooltip "Save current file")
1862 :action (make-instance 'action
1863 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1864 :tooltip "Save to a file")
1865 :action (make-instance 'action
1866 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1867 :accelerator "<control>Q" :tooltip "Quit"
1868 :callback (list #'widget-destroy :object window))
1869 :action (make-instance 'action
1870 :name "About" :label "_About"
1871 :accelerator "<control>A" :tooltip "About")
1872 :action (make-instance 'action
1873 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1874 :action (make-instance 'toggle-action
1875 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1876 :accelerator "<control>B" :tooltip "Bold" :active t)
1877 :actions (make-radio-group 'radio-action
1878 '((:name "Red" :value :red :label "_Red"
1879 :accelerator "<control>R" :tooltip "Blood")
1880 (:name "Green" :value :green :label "_Green"
1881 :accelerator "<control>G" :tooltip "Grass" :active t)
1882 (:name "Blue" :value :blue :label "_Blue"
1883 :accelerator "<control>B" :tooltip "Sky"))
1884 #'(lambda (active) (print active)))
1885 :actions (make-radio-group 'radio-action
1886 '((:name "Square" :value :square :label "_Square"
1887 :accelerator "<control>S" :tooltip "Square")
1888 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1889 :accelerator "<control>R" :tooltip "Rectangle")
1890 (:name "Oval" :value :oval :label "_Oval"
1891 :accelerator "<control>O" :tooltip "Egg"))
1892 #'(lambda (active) (print active)))))
1894 (ui-manager-add-ui ui *ui-description*)
1896 (make-instance 'v-box
1899 (ui-manager-get-widget ui "/MenuBar")
1900 :expand nil :fill nil)
1902 (ui-manager-get-widget ui "/ToolBar")
1903 :expand nil :fill nil)
1904 :child (make-instance 'label
1905 :label "Type Ctrl+Q to quit"
1906 :xalign 0.5 :yalign 0.5
1907 :width-request 200 :height-request 200))))
1913 (defun create-main-window (&optional display)
1914 (let* ((button-specs
1915 '(("button box" create-button-box)
1916 ("buttons" create-buttons)
1917 ("calendar" create-calendar)
1918 ("check buttons" create-check-buttons)
1919 ("color selection" create-color-selection)
1920 ("cursors" create-cursors)
1921 ("dialog" create-dialog)
1922 ("entry" create-entry)
1923 ("enxpander" create-expander)
1924 ("file chooser" create-file-chooser)
1925 ("font selection" create-font-selection)
1926 ("handle box" create-handle-box)
1927 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1928 ("icon view" create-icon-view)
1929 ("image" create-image)
1930 ("labels" create-labels)
1931 ("layout" create-layout)
1932 ("list" create-list)
1933 ("menus" create-menus)
1935 ("notebook" create-notebook)
1936 ("panes" create-panes)
1937 ("progress bar" create-progress-bar)
1938 ("radio buttons" create-radio-buttons)
1939 ("range controls" create-range-controls)
1941 ("reparent" create-reparent)
1942 ("rulers" create-rulers)
1943 ;; ("saved position")
1944 ("scrolled windows" create-scrolled-windows)
1945 ("size group" create-size-group)
1946 ("shapes" create-shapes)
1947 ("spinbutton" create-spins)
1948 ("statusbar" create-statusbar)
1949 ("test idle" create-idle-test)
1950 ("test timeout" create-timeout-test)
1951 ("text" create-text)
1952 ("toggle buttons" create-toggle-buttons)
1953 ("toolbar" create-toolbar-window)
1954 ("tooltips" create-tooltips)
1955 ("UI manager" create-ui-manager)))
1957 (main-window (make-instance 'window
1959 :title "testgtk.lisp" :name "main_window"
1960 :default-width 200 :default-height 400
1961 :allow-grow t :allow-shrink nil))
1962 (scrolled-window (make-instance 'scrolled-window
1963 :hscrollbar-policy :automatic
1964 :vscrollbar-policy :automatic
1966 (close-button (make-instance 'button
1967 :stock "gtk-close" :can-default t
1968 :signal (list 'clicked #'widget-destroy :object main-window))))
1970 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1972 (window-icon main-window)
1973 (gdk:pixbuf-add-alpha icon t 254 254 252)))
1976 (make-instance 'v-box
1978 :child-args '(:expand nil)
1979 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1980 :child (list (make-instance 'label :label (clg-version)) :fill nil)
1981 :child (list (make-instance 'label
1983 (format nil "~A (~A)"
1984 (lisp-implementation-type)
1986 (lisp-implementation-version)
1988 (let ((version (lisp-implementation-version)))
1989 (subseq version 0 (position #\sp version))))
1990 ;; The version string in CMUCL is far too long
1991 #+cmu(lisp-implementation-type))
1993 :child (list scrolled-window :expand t)
1994 :child (make-instance 'h-separator)
1995 :child (make-instance 'v-box
1996 :homogeneous nil :spacing 10 :border-width 10
1997 :child close-button))
2000 (make-instance 'v-box
2001 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
2002 :children (mapcar #'(lambda (spec)
2003 (apply #'create-button spec))
2005 (scrolled-window-add-with-viewport scrolled-window content-box))
2007 (widget-grab-focus close-button)
2008 (widget-show-all main-window)
2012 (within-main-loop (create-main-window))