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.
29 ;; $Id: testgtk.lisp,v 1.41 2007/07/12 09:18:30 espen Exp $
32 #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
35 (:use "COMMON-LISP" "CLG"))
37 (in-package "TESTGTK")
39 (defmacro define-toplevel (name (window title &rest initargs) &body body)
43 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
44 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
48 (if (not (widget-visible-p ,window))
50 (widget-hide ,window))))))
53 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
59 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
60 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
64 (if (not (widget-visible-p ,dialog))
66 (widget-hide ,dialog))))))
69 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
70 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
72 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
76 ;;; Pixmaps used in some of the tests
118 (defvar book-closed-xpm
143 (defvar mini-page-xpm
166 (defvar book-open-xpm
193 (defun create-bbox-in-frame (class frame-label spacing width height layout)
194 (declare (ignore width height))
195 (make-instance 'frame
197 :child (make-instance class
198 :border-width 5 :layout-style layout :spacing spacing
199 :child (make-instance 'button :stock "gtk-ok")
200 :child (make-instance 'button :stock "gtk-cancel")
201 :child (make-instance 'button :stock "gtk-help"))))
203 (define-toplevel create-button-box (window "Button Boxes")
204 (make-instance 'v-box
205 :parent window :border-width 10 :spacing 10
206 :child (make-instance 'frame
207 :label "Horizontal Button Boxes"
208 :child (make-instance 'v-box
209 :border-width 10 :spacing 10
212 (apply #'create-bbox-in-frame
214 '(("Spread" 40 85 20 :spread)
215 ("Edge" 40 85 20 :edge)
216 ("Start" 40 85 20 :start)
217 ("End" 40 85 20 :end)))))
218 :child (make-instance 'frame
219 :label "Vertical Button Boxes"
220 :child (make-instance 'h-box
221 :border-width 10 :spacing 10
224 (apply #'create-bbox-in-frame
226 '(("Spread" 30 85 20 :spread)
227 ("Edge" 30 85 20 :edge)
228 ("Start" 30 85 20 :start)
229 ("End" 30 85 20 :end)))))))
234 (define-simple-dialog create-buttons (dialog "Buttons")
235 (let ((table (make-instance 'table
236 :n-rows 3 :n-columns 3 :homogeneous nil
237 :row-spacing 5 :column-spacing 5 :border-width 10
241 collect (make-instance 'button
242 :label (format nil "button~D" (1+ n))))))
246 (let ((button (nth (+ (* 3 row) column) buttons))
247 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
248 (signal-connect button 'clicked
250 (if (widget-visible-p button+1)
251 (widget-hide button+1)
252 (widget-show button+1))))
253 (table-attach table button column (1+ column) row (1+ row)
254 :options '(:expand :fill)))))))
259 (define-simple-dialog create-calendar (dialog "Calendar")
260 (make-instance 'v-box
261 :parent dialog :border-width 10
262 :child (make-instance 'calendar)))
267 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
268 (make-instance 'v-box
269 :border-width 10 :spacing 10 :parent dialog
272 collect (make-instance 'check-button
273 :label (format nil "Button~D" n)))))
279 (define-dialog create-color-selection (dialog "Color selection dialog"
280 'color-selection-dialog
281 :allow-grow nil :allow-shrink nil
283 (with-slots (colorsel) dialog
284 (let ((button (make-instance 'check-button :label "Show Opacity")))
285 (dialog-add-action-widget dialog button
288 (color-selection-has-opacity-control-p colorsel)
289 (toggle-button-active-p button)))))
291 (let ((button (make-instance 'check-button :label "Show Palette")))
292 (dialog-add-action-widget dialog button
295 (color-selection-has-palette-p colorsel)
296 (toggle-button-active-p button)))))
298 (signal-connect dialog :ok
300 (let ((color (color-selection-current-color colorsel)))
301 (format t "Selected color: ~A~%" color)
302 (setf (color-selection-current-color colorsel) color)
303 (widget-hide dialog))))
305 (signal-connect dialog :cancel #'widget-destroy :object t)))
308 ;;; Cursors (Note: using the drawing function in Gdk is considered
309 ;;; deprecated in clg, new code should use Cairo instead)
311 (defun clamp (n min-val max-val)
312 (declare (number n min-val max-val))
313 (max (min n max-val) min-val))
315 (defun set-cursor (spinner drawing-area label)
318 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
320 (setf (label-label label) (string-downcase cursor))
321 (widget-set-cursor drawing-area cursor)))
323 (defun cursor-expose (drawing-area event)
324 (declare (ignore event))
325 (multiple-value-bind (width height)
326 (widget-get-size-allocation drawing-area)
327 (let* ((window (widget-window drawing-area))
328 (style (widget-style drawing-area))
329 (white-gc (style-white-gc style))
330 (gray-gc (style-bg-gc style :normal))
331 (black-gc (style-black-gc style)))
332 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
333 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
335 (gdk:draw-rectangle window gray-gc t (floor width 3)
336 (floor height 3) (floor width 3)
340 (define-simple-dialog create-cursors (dialog "Cursors")
341 (let ((spinner (make-instance 'spin-button
342 :adjustment (adjustment-new
344 (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
346 (drawing-area (make-instance 'drawing-area
347 :width-request 80 :height-request 80
348 :events '(:exposure :button-press)))
349 (label (make-instance 'label :label "XXX")))
351 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
353 (signal-connect drawing-area 'button-press-event
355 (case (gdk:event-button event)
356 (1 (spin-button-spin spinner :step-forward))
357 (3 (spin-button-spin spinner :step-backward)))
360 (signal-connect drawing-area 'scroll-event
362 (case (gdk:event-direction event)
363 (:up (spin-button-spin spinner :step-forward))
364 (:down (spin-button-spin spinner :step-backward)))
367 (signal-connect spinner 'changed
369 (set-cursor spinner drawing-area label)))
371 (make-instance 'v-box
372 :parent dialog :border-width 10 :spacing 5
374 (make-instance 'h-box
377 (make-instance 'label :label "Cursor Value : ")
381 :child (make-instance 'frame
382 :label "Cursor Area" :label-xalign 0.5 :border-width 10
384 :child (list label :expand nil))
386 (widget-realize drawing-area)
387 (set-cursor spinner drawing-area label)))
393 (defun create-dialog ()
395 (setq dialog (make-instance 'dialog
396 :title "Dialog" :default-width 200
398 :button (list "gtk-ok" #'widget-destroy :object t)
399 :signal (list 'destroy
401 (setq dialog nil)))))
403 (let ((label (make-instance 'label
404 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
406 (signal-connect dialog "Toggle"
408 (if (widget-visible-p label)
410 (widget-show label))))))
412 (if (widget-visible-p dialog)
414 (widget-show dialog))))
419 (define-simple-dialog create-entry (dialog "Entry")
420 (let ((main (make-instance 'v-box
421 :border-width 10 :spacing 10 :parent dialog)))
423 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
424 (editable-select-region entry 0 5) ; this has no effect when
426 ;; (editable-insert-text entry "great " 6)
427 ;; (editable-delete-text entry 6 12)
429 (let ((combo (make-instance 'combo-box-entry
434 "item3 item3 item3 item3"
435 "item4 item4 item4 item4 item4"
436 "item5 item5 item5 item5 item5 item5"
437 "item6 item6 item6 item6 item6"
438 "item7 item7 item7 item7"
441 (with-slots (child) combo
442 (setf (editable-text child) "hello world")
443 (editable-select-region child 0)))
445 (flet ((create-check-button (label slot)
446 (make-instance 'check-button
447 :label label :active t :parent main
448 :signal (list 'toggled
450 (setf (slot-value entry slot)
451 (toggle-button-active-p button)))
454 (create-check-button "Editable" 'editable)
455 (create-check-button "Visible" 'visibility)
456 (create-check-button "Sensitive" 'sensitive)))))
461 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
462 (make-instance 'v-box
463 :parent dialog :spacing 5 :border-width 5
464 :child (create-label "Expander demo. Click on the triangle for details.")
465 :child (make-instance 'expander
467 :child (create-label "Details can be shown or hidden."))))
470 ;; File chooser dialog
472 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
473 (file-chooser-add-filter dialog
474 (make-instance 'file-filter :name "All files" :pattern "*"))
475 (file-chooser-add-filter dialog
476 (make-instance 'file-filter :name "Common Lisp source code"
477 :patterns '("*.lisp" "*.lsp")))
479 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
480 (dialog-add-button dialog "gtk-ok"
482 (if (slot-boundp dialog 'filename)
483 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
484 (write-line "No files selected"))
485 (widget-destroy dialog))))
488 ;; Font selection dialog
490 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
491 (make-instance 'h-box
492 :parent window :spacing 8 :border-width 8
493 :child (make-instance 'label :label "Pick a font")
494 :child (make-instance 'font-button
495 :use-font t :title "Font Selection Dialog")))
501 (defun get-directory-listing (directory)
502 (let ((dir #+cmu(unix:open-dir directory)
503 #+sbcl(sb-posix:opendir directory)))
506 as filename = #+cmu(unix:read-dir dir)
507 #+sbcl(let ((dirent (sb-posix:readdir dir)))
508 (unless (sb-grovel::foreign-nullp dirent)
509 (sb-posix:dirent-name dirent)))
511 collect (let* ((pathname (format nil "~A~A" directory filename))
513 #+cmu(eq (unix:unix-file-kind pathname) :directory)
514 #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
515 (list filename directory-p)))
516 #+cmu(unix:close-dir dir)
517 #+sbcl(sb-posix:closedir dir))))
520 (defun get-directory-listing (directory)
522 (mapcar #'(lambda (entry)
523 (let ((pathname (namestring (first entry))))
524 (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
525 (directory (format nil "~A*" directory) :full t))
526 (mapcar #'(lambda (entry)
527 (let ((pathname (namestring entry)))
528 (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
530 (directory (format nil "~A*/" directory)))))
533 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
534 (let ((file-pixbuf nil)
536 (defun load-pixbufs ()
540 file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
541 folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
542 (glib:glib-error (condition)
543 (make-instance 'message-dialog
544 :message-type :error :visible t
545 :text "<b>Failed to load an image</b>"
546 :secondary-text (glib:gerror-message condition)
547 :signal (list :ok #'widget-destroy :object t))
548 (return-from load-pixbufs nil))))
551 (defun fill-store (store directory)
552 (list-store-clear store)
554 for (filename directory-p) in (get-directory-listing directory)
555 unless (or (string= filename ".") (string= filename ".."))
556 do (list-store-insert store 0
559 (if directory-p folder-pixbuf file-pixbuf)
562 (defun sort-func (store a b)
563 (let ((a-dir-p (tree-model-value store a 'directory-p))
564 (b-dir-p (tree-model-value store b 'directory-p))
565 (a-name (tree-model-value store a 'filename))
566 (b-name (tree-model-value store b 'filename)))
568 ((and a-dir-p (not b-dir-p)) :before)
569 ((and (not a-dir-p) b-dir-p) :after)
570 ((string< a-name b-name) :before)
571 ((string> a-name b-name) :after)
575 (defun parent-dir (dir)
576 (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
579 (define-toplevel create-icon-view (window "Icon View demo"
582 (if (not (load-pixbufs))
583 (widget-destroy window)
584 (let* ((directory "/")
585 (store (make-instance 'list-store
586 :column-types '(string gdk:pixbuf boolean)
587 :column-names '(filename pixbuf directory-p)))
588 (icon-view (make-instance 'icon-view
589 :model store :selection-mode :multiple
590 :text-column 'filename
591 :pixbuf-column 'pixbuf))
592 (up (make-instance 'tool-button
593 :stock "gtk-go-up" :is-important t :sensitive nil))
594 (home (make-instance 'tool-button
595 :stock "gtk-home" :is-important t)))
596 (tree-sortable-set-sort-func store :default #'sort-func)
597 (tree-sortable-set-sort-column store :default :ascending)
598 (fill-store store directory)
600 (signal-connect icon-view 'item-activated
602 (when (tree-model-value store path 'directory-p)
604 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
605 (fill-store store directory)
606 (setf (widget-sensitive-p up) t))))
608 (signal-connect up 'clicked
610 (unless (string= directory "/")
611 (setq directory (parent-dir directory))
612 (fill-store store directory)
614 (widget-sensitive-p home)
615 (not (string= directory (namestring (truename #p"clg:")))))
616 (setf (widget-sensitive-p up) (not (string= directory "/"))))))
618 (signal-connect home 'clicked
620 (setq directory (namestring (truename #p"clg:")))
621 (fill-store store directory)
622 (setf (widget-sensitive-p up) t)
623 (setf (widget-sensitive-p home) nil)))
625 (make-instance 'v-box
628 (make-instance 'toolbar :child up :child home)
629 :fill nil :expand nil)
630 :child (make-instance 'scrolled-window
631 :shadow-type :etched-in :policy :automatic
632 :child icon-view))))))
637 (define-toplevel create-image (window "Image" :resizable nil)
638 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
643 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
644 (flet ((create-label-in-frame (frame-label label-text &rest args)
645 (make-instance 'frame
647 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
648 (make-instance 'h-box
649 :spacing 5 :parent window
650 :child-args '(:fill nil :expand nil)
651 :child (make-instance 'v-box
652 :spacing 5 :child-args '(:fill nil :expand nil)
653 :child (create-label-in-frame "Normal Label" "This is a Normal label")
654 :child (create-label-in-frame "Multi-line Label"
655 "This is a Multi-line label.
658 :child (create-label-in-frame "Left Justified Label"
659 "This is a Left-Justified
663 :child (create-label-in-frame "Right Justified Label"
664 "This is a Right-Justified
668 :child (make-instance 'v-box
669 :spacing 5 :child-args '(:fill nil :expand nil)
670 :child (create-label-in-frame "Line wrapped label"
671 "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.
672 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
675 :child (create-label-in-frame "Filled, wrapped label"
676 "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.
677 This is a new paragraph.
678 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
679 :justify :fill :wrap t)
681 :child (create-label-in-frame "Underlined label"
682 "This label is underlined!
683 This one is underlined in quite a funky fashion"
685 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
688 ;;; Layout (Note: using the drawing function in Gdk is considered
689 ;;; deprecated in clg, new code should use Cairo instead)
691 (defun layout-expose (layout event)
692 (when (eq (gdk:event-window event) (layout-bin-window layout))
693 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
694 (let ((imin (truncate gdk:x 10))
695 (imax (truncate (+ gdk:x gdk:width 9) 10))
696 (jmin (truncate gdk:y 10))
697 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
699 (let ((window (layout-bin-window layout))
700 (gc (style-black-gc (widget-style layout))))
702 for i from imin below imax
704 for j from jmin below jmax
705 unless (zerop (mod (+ i j) 2))
706 do (gdk:draw-rectangle
707 window gc t (* 10 i) (* 10 j)
708 (1+ (mod i 10)) (1+ (mod j 10)))))))))
711 (define-toplevel create-layout (window "Layout" :default-width 200
713 (let ((layout (make-instance 'layout
714 :parent (make-instance 'scrolled-window :parent window)
715 :width 1600 :height 128000 :events '(:exposure)
716 :signal (list 'expose-event #'layout-expose :object t))))
718 (with-slots (hadjustment vadjustment) layout
720 (adjustment-step-increment hadjustment) 10.0
721 (adjustment-step-increment vadjustment) 10.0))
725 (let ((text (format nil "Button ~D, ~D" i j)))
727 (make-instance (if (not (zerop (mod (+ i j) 2)))
730 :label text :visible t)
731 (* j 100) (* i 100)))))
734 for i from 16 below 1280
735 do (let ((text (format nil "Button ~D, ~D" i 0)))
737 (make-instance (if (not (zerop (mod i 2)))
740 :label text :visible t)
747 (define-simple-dialog create-list (dialog "List" :default-height 400)
748 (let* ((store (make-instance 'list-store
749 :column-types '(string integer boolean)
750 :column-names '(:foo :bar :baz)
751 :initial-content '(#("First" 12321 nil)
752 (:foo "Yeah" :baz t))))
753 (tree (make-instance 'tree-view :model store)))
756 with iter = (make-instance 'tree-iter)
758 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
760 (let ((column (make-instance 'tree-view-column :title "Column 1"))
761 (cell (make-instance 'cell-renderer-text)))
762 (cell-layout-pack column cell :expand t)
763 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
764 (tree-view-append-column tree column))
766 (let ((column (make-instance 'tree-view-column :title "Column 2"))
767 (cell (make-instance 'cell-renderer-text :background "orange")))
768 (cell-layout-pack column cell :expand t)
769 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
770 (tree-view-append-column tree column))
772 (let ((column (make-instance 'tree-view-column :title "Column 3"))
773 (cell (make-instance 'cell-renderer-text)))
774 (cell-layout-pack column cell :expand t)
775 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
776 (tree-view-append-column tree column))
778 (make-instance 'v-box
779 :parent dialog :border-width 10 :spacing 10
781 (make-instance 'h-box
783 :child (make-instance 'button
784 :label "Remove Selection"
785 :signal (list 'clicked
790 (make-instance 'tree-row-reference :model store :path path))
791 (tree-selection-get-selected-rows
792 (tree-view-selection tree)))))
794 #'(lambda (reference)
795 (list-store-remove store reference))
799 (make-instance 'h-box
801 :child (make-instance 'check-button
802 :label "Show Headers" :active t
803 :signal (list 'toggled
806 (tree-view-headers-visible-p tree)
807 (toggle-button-active-p button)))
809 :child (make-instance 'check-button
810 :label "Reorderable" :active nil
811 :signal (list 'toggled
814 (tree-view-reorderable-p tree)
815 (toggle-button-active-p button)))
818 (make-instance 'h-box
819 :child (make-instance 'label :label "Selection Mode: ")
820 :child (make-instance 'combo-box
821 :content '("Single" "Browse" "Multiple")
823 :signal (list 'changed
824 #'(lambda (combo-box)
827 (tree-view-selection tree))
829 #(:single :browse :multiple)
830 (combo-box-active combo-box))))
834 :child (make-instance 'scrolled-window
835 :child tree :hscrollbar-policy :automatic))))
840 (defun create-menu (depth tearoff)
841 (unless (zerop depth)
842 (let ((menu (make-instance 'menu)))
844 (let ((menu-item (make-instance 'tearoff-menu-item)))
845 (menu-shell-append menu menu-item)))
849 (make-instance 'radio-menu-item
850 :label (format nil "item ~2D - ~D" depth (1+ i)))))
852 (add-to-radio-group menu-item group)
853 (setq group menu-item))
854 (unless (zerop (mod depth 2))
855 (setf (check-menu-item-active-p menu-item) t))
856 (menu-shell-append menu menu-item)
858 (setf (widget-sensitive-p menu-item) nil))
859 (let ((submenu (create-menu (1- depth) t)))
861 (setf (menu-item-submenu menu-item) submenu))))))
865 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
866 (let* ((main (make-instance 'v-box :parent dialog))
867 ; (accel-group (make-instance 'accel-group))
868 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
869 ; (window-add-accel-group dialog accel-group)
871 (let ((menu-item (make-instance 'menu-item
872 :label (format nil "test~%line2"))))
873 (setf (menu-item-submenu menu-item) (create-menu 2 t))
874 (menu-shell-append menubar menu-item))
876 (let ((menu-item (make-instance 'menu-item :label "foo")))
877 (setf (menu-item-submenu menu-item) (create-menu 3 t))
878 (menu-shell-append menubar menu-item))
880 (let ((menu-item (make-instance 'menu-item :label "bar")))
881 (setf (menu-item-submenu menu-item) (create-menu 4 t))
882 (setf (menu-item-right-justified-p menu-item) t)
883 (menu-shell-append menubar menu-item))
885 (make-instance 'v-box
886 :spacing 10 :border-width 10 :parent main
887 :child (make-instance 'combo-box
891 collect (format nil "Item ~D" i))))
893 (widget-show-all main)))
898 (defun create-notebook-page (notebook page-num book-closed)
899 (let* ((title (format nil "Page ~D" page-num))
900 (page (make-instance 'frame :label title :border-width 10))
901 (v-box (make-instance 'v-box
902 :homogeneous t :border-width 10 :parent page)))
904 (make-instance 'h-box
905 :parent (list v-box :fill nil :padding 5) :homogeneous t
906 :child-args '(:padding 5)
907 :child (make-instance 'check-button
908 :label "Fill Tab" :active t
909 :signal (list 'toggled
912 (notebook-child-tab-fill-p page)
913 (toggle-button-active-p button)))
915 :child (make-instance 'check-button
917 :signal (list 'toggled
920 (notebook-child-tab-expand-p page)
921 (toggle-button-active-p button)))
923 :child (make-instance 'check-button
925 :signal (list 'toggled
928 (notebook-child-tab-pack page)
929 (if (toggle-button-active-p button)
933 :child (make-instance 'button
935 :signal (list 'clicked #'(lambda () (widget-hide page)))))
938 (let ((label-box (make-instance 'h-box
940 :child-args '(:expand nil)
941 :child (make-instance 'image :pixbuf book-closed)
942 :child (make-instance 'label :label title)))
943 (menu-box (make-instance 'h-box
945 :child-args '(:expand nil)
946 :child (make-instance 'image :pixbuf book-closed)
947 :child (make-instance 'label :label title))))
949 (notebook-append notebook page label-box menu-box))))
951 (define-simple-dialog create-notebook (dialog "Notebook")
952 (let ((main (make-instance 'v-box :parent dialog)))
953 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
954 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
955 (notebook (make-instance 'notebook
956 :border-width 10 :tab-pos :top :parent main)))
958 (flet ((set-image (page func pixbuf)
961 (first (container-children (funcall func notebook page))))
963 (signal-connect notebook 'switch-page
964 #'(lambda (pointer page)
965 (declare (ignore pointer))
966 (set-image page #'notebook-menu-label book-open)
967 (set-image page #'notebook-tab-label book-open)
968 (when (slot-boundp notebook 'current-page)
969 (let ((curpage (notebook-current-page notebook)))
970 (set-image curpage #'notebook-menu-label book-closed)
971 (set-image curpage #'notebook-tab-label book-closed))))))
972 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
974 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
976 (make-instance 'h-box
977 :spacing 5 :border-width 10
978 :parent (list main :expand nil)
979 :child-args '(:fill nil)
980 :child (make-instance 'check-button
982 :signal (list 'clicked
984 (if (toggle-button-active-p button)
985 (notebook-popup-enable notebook)
986 (notebook-popup-disable notebook)))
988 :child (make-instance 'check-button
989 :label "Homogeneous tabs"
990 :signal (list 'clicked
993 (notebook-homogeneous-p notebook)
994 (toggle-button-active-p button)))
997 (make-instance 'h-box
998 :spacing 5 :border-width 10
999 :parent (list main :expand nil)
1000 :child-args '(:expand nil)
1001 :child (make-instance 'label :label "Notebook Style: ")
1002 :child (let ((scrollable-p nil))
1003 (make-instance 'combo-box
1004 :content '("Standard" "No tabs" "Scrollable") :active 0
1005 :signal (list 'changed
1006 #'(lambda (combo-box)
1007 (case (combo-box-active combo-box)
1009 (setf (notebook-show-tabs-p notebook) t)
1011 (setq scrollable-p nil)
1012 (setf (notebook-scrollable-p notebook) nil)
1014 do (notebook-remove-page notebook 5))))
1016 (setf (notebook-show-tabs-p notebook) nil)
1018 (setq scrollable-p nil)
1019 (setf (notebook-scrollable-p notebook) nil)
1021 do (notebook-remove-page notebook 5))))
1023 (unless scrollable-p
1024 (setq scrollable-p t)
1025 (setf (notebook-show-tabs-p notebook) t)
1026 (setf (notebook-scrollable-p notebook) t)
1027 (loop for i from 6 to 15
1028 do (create-notebook-page notebook i book-closed))))))
1030 :child (make-instance 'button
1031 :label "Show all Pages"
1032 :signal (list 'clicked
1034 (map-container nil #'widget-show notebook)))))
1036 (make-instance 'h-box
1037 :spacing 5 :border-width 10
1038 :parent (list main :expand nil)
1039 :child (make-instance 'button
1041 :signal (list 'clicked #'notebook-prev-page :object notebook))
1042 :child (make-instance 'button
1044 :signal (list 'clicked #'notebook-next-page :object notebook))
1045 :child (make-instance 'button
1047 :signal (let ((tab-pos 0))
1050 (setq tab-pos (mod (1+ tab-pos) 4))
1052 (notebook-tab-pos notebook)
1053 (svref #(:top :right :bottom :left) tab-pos))))))))
1054 (widget-show-all main)))
1060 (defun toggle-resize (child)
1061 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1063 (defun toggle-shrink (child)
1064 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1066 (defun create-pane-options (paned frame-label label1 label2)
1067 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1068 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1069 (let ((check-button (make-instance 'check-button :label "Resize")))
1070 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1071 (signal-connect check-button 'toggled
1072 #'toggle-resize :object (paned-child1 paned)))
1073 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1074 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1075 (signal-connect check-button 'toggled
1076 #'toggle-shrink :object (paned-child1 paned)))
1078 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1079 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1080 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1081 (signal-connect check-button 'toggled
1082 #'toggle-resize :object (paned-child2 paned)))
1083 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1084 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1085 (signal-connect check-button 'toggled
1086 #'toggle-shrink :object (paned-child2 paned)))
1087 (make-instance 'frame :label frame-label :border-width 4 :child table)))
1089 (define-toplevel create-panes (window "Panes")
1090 (let* ((hpaned (make-instance 'h-paned
1091 :child1 (make-instance 'frame
1092 :width-request 60 :height-request 60
1094 :child (make-instance 'button :label "Hi there"))
1095 :child2 (make-instance 'frame
1096 :width-request 80 :height-request 60
1098 (vpaned (make-instance 'v-paned
1101 :child2 (make-instance 'frame
1102 :width-request 80 :height-request 60
1103 :shadow-type :in))))
1105 (make-instance 'v-box
1107 :child-args '(:expand nil)
1108 :child (list vpaned :expand t)
1109 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1110 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1115 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1116 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1117 (activity-mode-button (make-instance 'check-button
1118 :label "Activity mode"))
1119 (timer (timeout-add 100
1121 (if (toggle-button-active-p activity-mode-button)
1122 (progress-bar-pulse progress)
1123 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1125 (progress-bar-fraction progress)
1131 (make-instance 'v-box
1132 :parent dialog :border-width 10 :spacing 10
1134 :child activity-mode-button)
1136 (signal-connect dialog 'destroy
1137 #'(lambda () (when timer (timeout-remove timer))))))
1142 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1143 (make-instance 'v-box
1144 :parent dialog :border-width 10 :spacing 10
1145 :children (make-radio-group 'radio-button
1146 '((:label "button1") (:label "button2") (:label "button3"))
1152 (define-simple-dialog create-range-controls (dialog "Range controls")
1153 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1154 (make-instance 'v-box
1155 :parent dialog :border-width 10 :spacing 10
1156 :child (make-instance 'h-scale
1157 :width-request 150 :adjustment adjustment :inverted t
1158 :update-policy :delayed :digits 1 :draw-value t)
1159 :child (make-instance 'h-scrollbar
1160 :adjustment adjustment :update-policy :continuous))))
1165 (define-simple-dialog create-reparent (dialog "Reparent")
1166 (let ((main (make-instance 'h-box
1167 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1168 (label (make-instance 'label :label "Hello World")))
1170 (flet ((create-frame (title)
1171 (let* ((frame (make-instance 'frame :label title :parent main))
1172 (box (make-instance 'v-box
1173 :spacing 5 :border-width 5 :parent frame))
1174 (button (make-instance 'button
1175 :label "switch" :parent (list box :expand nil))))
1176 (signal-connect button 'clicked
1178 (widget-reparent label box)))
1181 (box-pack-start (create-frame "Frame 1") label nil t 0)
1182 (create-frame "Frame 2"))
1183 (widget-show-all main)))
1188 (define-toplevel create-rulers (window "Rulers"
1189 :default-width 300 :default-height 300
1190 :events '(:pointer-motion :pointer-motion-hint))
1191 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1192 (h-ruler (make-instance 'h-ruler
1193 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1194 :position 0.0d0 :max-size 20.0d0))
1195 (v-ruler (make-instance 'v-ruler
1196 :lower 5.0d0 :upper 15.0d0
1197 :position 0.0d0 :max-size 20.0d0)))
1198 (signal-connect window 'motion-notify-event
1200 (widget-event h-ruler event)
1201 (widget-event v-ruler event)))
1202 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1203 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1208 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1210 :default-height 300)
1211 (let* ((scrolled-window
1212 (make-instance 'scrolled-window
1213 :parent dialog :border-width 10
1214 :vscrollbar-policy :automatic
1215 :hscrollbar-policy :automatic))
1217 (make-instance 'table
1218 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1219 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1220 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1222 (scrolled-window-add-with-viewport scrolled-window table)
1226 (make-instance 'toggle-button
1227 :label (format nil "button (~D,~D)~%" i j))))
1228 (table-attach table button i (1+ i) j (1+ j)))))
1229 (widget-show-all scrolled-window)))
1234 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1235 (let ((size-group (make-instance 'size-group)))
1236 (flet ((create-frame (label rows)
1237 (let ((table (make-instance 'table
1238 :n-rows (length rows) :n-columns 2 :homogeneous nil
1239 :row-spacing 5 :column-spacing 10 :border-width 5)))
1243 do (table-attach table
1244 (create-label (first row) :xalign 0 :yalign 1)
1245 0 1 i (1+ i) :x-options '(:expand :fill))
1246 (let ((combo (make-instance 'combo-box
1247 :content (rest row) :active 0)))
1248 (size-group-add-widget size-group combo)
1249 (table-attach table combo 1 2 i (1+ i))))
1250 (make-instance 'frame :label label :child table))))
1252 (make-instance 'v-box
1253 :parent dialog :border-width 5 :spacing 5
1254 :child (create-frame "Color Options"
1255 '(("Foreground" "Red" "Green" "Blue")
1256 ("Background" "Red" "Green" "Blue")))
1257 :child (create-frame "Line Options"
1258 '(("Dashing" "Solid" "Dashed" "Dotted")
1259 ("Line ends" "Square" "Round" "Arrow")))
1260 :child (create-check-button "Enable grouping"
1263 (size-group-mode size-group)
1264 (if active :horizontal :none)))
1270 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1272 (make-instance 'window
1273 :type type :default-width 100 :default-height 100
1274 :events '(:button-motion :pointer-motion-hint :button-press)
1275 :signal (list 'destroy destroy))))
1277 (widget-realize window)
1278 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1279 (let ((fixed (make-instance 'fixed :parent window)))
1280 (fixed-put fixed (create-image-widget source mask) px py))
1281 (widget-shape-combine-mask window mask px py))
1285 (declare (fixnum x-offset y-offset))
1286 (signal-connect window 'button-press-event
1288 (when (typep event 'gdk:button-press-event)
1289 (setq x-offset (truncate (gdk:event-x event)))
1290 (setq y-offset (truncate (gdk:event-y event)))
1292 (gdk:pointer-grab (widget-window window)
1293 :events '(:button-release :button-motion :pointer-motion-hint)
1296 (signal-connect window 'button-release-event
1298 (declare (ignore event))
1299 (grab-remove window)
1300 (gdk:pointer-ungrab)))
1302 (signal-connect window 'motion-notify-event
1304 (declare (ignore event))
1305 (multiple-value-bind (win xp yp mask)
1306 (gdk:window-get-pointer root-window)
1307 (declare (ignore mask win) (fixnum xp yp))
1308 (window-move window (- xp x-offset) (- yp y-offset))))))
1310 (window-move window x y)
1311 (widget-show-all window)
1315 (let ((modeller nil)
1318 (defun create-shapes ()
1319 (let ((root-window (gdk:get-root-window)))
1324 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1325 #'(lambda () (setq modeller nil))))
1326 (widget-destroy modeller))
1332 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1333 #'(lambda () (setq sheets nil))))
1334 (widget-destroy sheets))
1340 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1341 #'(lambda () (setq rings nil))))
1342 (widget-destroy rings)))))
1348 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1349 (let ((main (make-instance 'v-box
1350 :spacing 5 :border-width 10 :parent dialog)))
1352 (flet ((create-date-spinner (label adjustment shadow-type)
1353 (declare (ignore shadow-type))
1354 (make-instance 'v-box
1355 :child-args '(:expand nil)
1356 :child (make-instance 'label
1357 :label label :xalign 0.0 :yalign 0.5)
1358 :child (make-instance 'spin-button
1359 :adjustment adjustment :wrap t))))
1360 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1362 (declare (ignore sec min hour day daylight-p zone))
1363 (make-instance 'frame
1364 :label "Not accelerated" :parent main
1365 :child (make-instance 'h-box
1367 :child-args '(:padding 5)
1368 :child (create-date-spinner "Day : "
1369 (adjustment-new date 1 31 1 5 0) :out)
1370 :child (create-date-spinner "Month : "
1371 (adjustment-new month 1 12 1 5 0) :etched-in)
1372 :child (create-date-spinner "Year : "
1373 (adjustment-new year 0 2100 1 100 0) :in)))))
1375 (let ((spinner1 (make-instance 'spin-button
1376 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1377 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1378 (spinner2 (make-instance 'spin-button
1379 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1380 :climb-rate 1.0 :wrap t))
1381 (value-label (make-instance 'label :label "0")))
1382 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1385 (spin-button-digits spinner1)
1386 (floor (spin-button-value spinner2)))))
1388 (make-instance 'frame
1389 :label "Accelerated" :parent main
1390 :child (make-instance 'v-box
1393 (make-instance 'h-box
1394 :child-args '(:padding 5)
1395 :child (make-instance 'v-box
1396 :child (make-instance 'label
1398 :xalign 0.0 :yalign 0.5)
1400 :child (make-instance 'v-box
1401 :child (make-instance 'label
1403 :xalign 0.0 :yalign 0.5)
1405 :expand nil :padding 5)
1406 :child (make-instance 'check-button
1407 :label "Snap to 0.5-ticks" :active t
1408 :signal (list 'clicked
1411 (spin-button-snap-to-ticks-p spinner1)
1412 (toggle-button-active-p button)))
1414 :child (make-instance 'check-button
1415 :label "Numeric only input mode" :active t
1416 :signal (list 'clicked
1419 (spin-button-numeric-p spinner1)
1420 (toggle-button-active-p button)))
1424 (make-instance 'h-box
1425 :child-args '(:padding 5)
1426 :child (make-instance 'button
1427 :label "Value as Int"
1428 :signal (list 'clicked
1431 (label-label value-label)
1433 (spin-button-value-as-int
1435 :child (make-instance 'button
1436 :label "Value as Float"
1437 :signal (list 'clicked
1440 (label-label value-label)
1442 (format nil "~~,~DF"
1443 (spin-button-digits spinner1))
1444 (spin-button-value spinner1)))))))
1445 :padding 5 :expand nil))))
1446 (widget-show-all main)))
1451 (define-toplevel create-statusbar (window "Statusbar")
1452 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1453 (close-button (create-button '("close" :can-default t)
1454 #'widget-destroy :object window))
1457 (signal-connect statusbar 'text-popped
1458 #'(lambda (context-id text)
1459 (declare (ignore context-id))
1460 (format nil "Popped: ~A~%" text)))
1462 (make-instance 'v-box
1464 :child (make-instance 'v-box
1465 :border-width 10 :spacing 10
1466 :child (create-button "push something"
1468 (statusbar-push statusbar 1
1469 (format nil "something ~D" (incf counter)))))
1470 :child (create-button "pop"
1472 (statusbar-pop statusbar 1)))
1473 :child (create-button "steal #4"
1475 (statusbar-remove statusbar 1 4)))
1476 :child (create-button "dump stack")
1477 :child (create-button "test contexts"))
1478 :child (list (make-instance 'h-separator) :expand nil)
1480 (make-instance 'v-box :border-width 10 :child close-button)
1482 :child (list statusbar :expand nil))
1484 (widget-grab-focus close-button)))
1489 (define-simple-dialog create-idle-test (dialog "Idle Test")
1490 (let ((label (make-instance 'label
1491 :label "count: 0" :xpad 10 :ypad 10))
1494 (signal-connect dialog 'destroy
1495 #'(lambda () (when idle (idle-remove idle))))
1497 (make-instance 'v-box
1498 :parent dialog :border-width 10 :spacing 10
1500 :child (make-instance 'frame
1501 :label "Label Container" :border-width 5
1502 :child(make-instance 'v-box
1503 :children (make-radio-group 'radio-button
1504 '((:label "Resize-Parent" :value :parent :active t)
1505 (:label "Resize-Queue" :value :queue)
1506 (:label "Resize-Immediate" :value :immediate))
1509 (container-resize-mode (dialog-action-area dialog)) mode))))))
1511 (dialog-add-button dialog "Start"
1518 (setf (label-label label) (format nil "count: ~D" count))
1521 (dialog-add-button dialog "Stop"
1525 (setq idle nil))))))
1531 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1532 (let ((label (make-instance 'label
1533 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1536 (signal-connect dialog 'destroy
1537 #'(lambda () (when timer (timeout-remove timer))))
1539 (dialog-add-button dialog "Start"
1546 (setf (label-label label) (format nil "count: ~D" count))
1549 (dialog-add-button dialog "Stop"
1552 (timeout-remove timer)
1553 (setq timer nil))))))
1558 (define-simple-dialog create-text (dialog "Text" :default-width 400
1559 :default-height 400)
1560 (let* ((text-view (make-instance 'text-view
1561 :border-width 10 :visible t :wrap-mode :word))
1562 (buffer (text-view-buffer text-view))
1565 (text-buffer-create-tag buffer "Bold" :weight :bold)
1566 (text-buffer-create-tag buffer "Italic" :style :italic)
1567 (text-buffer-create-tag buffer "Underline" :underline :single)
1569 (flet ((create-toggle-callback (tag-name)
1570 (let ((tag (text-tag-table-lookup
1571 (text-buffer-tag-table buffer) tag-name)))
1573 (unless (eq (and (find tag active-tags) t) active)
1576 (push tag active-tags)
1577 (setq active-tags (delete tag active-tags)))
1578 (multiple-value-bind (non-zero-p start end)
1579 (text-buffer-get-selection-bounds buffer)
1580 (declare (ignore non-zero-p))
1582 (text-buffer-apply-tag buffer tag start end)
1583 (text-buffer-remove-tag buffer tag start end))))))))
1586 (make-instance 'action-group
1587 :action (make-instance 'toggle-action
1588 :name "Bold" :stock-id "gtk-bold" :label "Bold"
1589 :accelerator "<control>B" :tooltip "Bold"
1590 :callback (create-toggle-callback "Bold"))
1591 :action (make-instance 'toggle-action
1592 :name "Italic" :stock-id "gtk-italic" :label "Italic"
1593 :accelerator "<control>I" :tooltip "Italic"
1594 :callback (create-toggle-callback "Italic"))
1595 :action (make-instance 'toggle-action
1596 :name "Underline" :stock-id "gtk-underline"
1597 :label "Underline" :accelerator "<control>U"
1598 :tooltip "Underline"
1599 :callback (create-toggle-callback "Underline"))))
1600 (ui (make-instance 'ui-manager
1601 :action-group actions
1602 :ui '((:toolbar "ToolBar"
1604 (:toolitem "Italic")
1605 (:toolitem "Underline"))))))
1607 ;; Callback to activate/deactivate toolbar buttons when cursor
1609 (signal-connect buffer 'mark-set
1610 #'(lambda (location mark)
1611 (declare (ignore mark))
1612 (text-tag-table-foreach (text-buffer-tag-table buffer)
1617 (text-iter-has-tag-p location tag)
1618 (not (text-iter-begins-tag-p location tag)))
1619 (text-iter-ends-tag-p location tag))))
1620 (unless (eq active (and (find tag active-tags) t))
1622 (push tag active-tags)
1623 (setq active-tags (delete tag active-tags)))
1625 (toggle-action-active-p
1626 (action-group-get-action actions (text-tag-name tag)))
1629 ;; Callback to apply active tags when a character is inserted
1630 (signal-connect buffer 'insert-text
1631 #'(lambda (iter &rest args)
1632 (declare (ignore args))
1633 (let ((before (text-buffer-get-iter-at-offset buffer
1634 (1- (text-iter-offset iter)))))
1636 for tag in active-tags
1637 do (text-buffer-apply-tag buffer tag before iter))))
1640 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1641 (container-add dialog text-view)
1643 (let ((position (make-instance 'label :visible t)))
1644 (flet ((update-position (line column)
1646 (label-label position)
1647 (format nil "Cursor Position: ~d,~d" (1+ line) column))))
1648 (update-position 0 0)
1650 ;; Callback to display current position when cursor is moved
1651 (signal-connect buffer 'mark-set
1652 #'(lambda (iter mark)
1654 (slot-boundp mark 'name)
1655 (string= (text-mark-name mark) "insert"))
1657 (text-iter-line iter) (text-iter-line-offset iter)))))
1659 ;; Callback to display current position after the
1660 ;; buffer has been modified
1661 (signal-connect buffer 'changed
1663 (let ((iter (text-buffer-get-iter-at-insert buffer)))
1665 (text-iter-line iter) (text-iter-line-offset iter))))
1668 (container-add dialog position :expand nil))))))
1673 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1674 (make-instance 'v-box
1675 :border-width 10 :spacing 10 :parent dialog
1678 collect (make-instance 'toggle-button
1679 :label (format nil "Button~D" (1+ n))))))
1685 (defun create-toolbar (window)
1686 (make-instance 'toolbar
1687 :show-tooltips t :show-arrow nil
1689 ;; Insert a stock item
1690 :child (make-instance 'tool-button
1692 :tip-text "Destroy toolbar"
1693 :tip-private "Toolbar/Quit"
1694 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1696 :child (make-instance 'separator-tool-item)
1698 :child (make-instance 'tool-button
1699 :label "Horizontal" :stock "gtk-go-forward"
1700 :tip-text "Horizontal toolbar layout"
1701 :tip-private "Toolbar/Horizontal"
1702 :signal (list 'clicked
1704 (setf (toolbar-orientation toolbar) :horizontal))
1707 :child (make-instance 'tool-button
1708 :label "Vertical" :stock "gtk-go-down"
1709 :tip-text "Vertical toolbar layout"
1710 :tip-private "Toolbar/Vertical"
1711 :signal (list 'clicked
1713 (setf (toolbar-orientation toolbar) :vertical))
1716 :child (make-instance 'separator-tool-item)
1718 :children (make-radio-group 'radio-tool-button
1719 '((:label "Icons" :stock "gtk-justify-left"
1720 :tip-text "Only show toolbar icons"
1721 :tip-private "Toolbar/IconsOnly"
1723 (:label "Both" :stock "gtk-justify-center"
1724 :tip-text "Show toolbar icons and text"
1725 :tip-private "Toolbar/Both"
1726 :value :both :active t)
1727 (:label "Text" :stock "gtk-justify-right"
1728 :tip-text "Show toolbar text"
1729 :tip-private "Toolbar/TextOnly"
1732 #'(lambda (toolbar style)
1733 (setf (toolbar-style toolbar) style))
1736 :child (make-instance 'separator-tool-item)
1738 :child (make-instance 'tool-item
1739 :child (make-instance 'entry)
1740 :tip-text "This is an unusable GtkEntry"
1741 :tip-private "Hey don't click me!")
1743 :child (make-instance 'separator-tool-item)
1745 :child (make-instance 'tool-button
1746 :label "Enable" :stock "gtk-add"
1747 :tip-text "Enable tooltips"
1748 :tip-private "Toolbar/EnableTooltips"
1749 :signal (list 'clicked
1751 (setf (toolbar-show-tooltips-p toolbar) t))
1754 :child (make-instance 'tool-button
1755 :label "Disable" :stock "gtk-remove"
1756 :tip-text "Disable tooltips"
1757 :tip-private "Toolbar/DisableTooltips"
1758 :signal (list 'clicked
1760 (setf (toolbar-show-tooltips-p toolbar) nil))
1763 ;; :child (make-instance 'separator-tool-item)
1765 ;; :child (make-instance 'tool-button
1766 ;; :label "GTK" :icon #p"clg:examples;gtk.png"
1767 ;; :tip-text "GTK+ Logo"
1768 ;; :tip-private "Toolbar/GTK+")
1771 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1772 (container-add window (create-toolbar window)))
1777 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1778 (make-instance 'v-box
1780 :child (create-label "Above")
1781 :child (make-instance 'h-separator)
1782 :child (make-instance 'h-box
1785 (make-instance 'handle-box
1786 :child (create-toolbar window)
1787 :signal (list 'child-attached
1789 (format t "~A attached~%" child)))
1790 :signal (list 'child-detached
1792 (format t "~A detached~%" child))))
1793 :expand nil :fill :nil))
1794 :child (make-instance 'h-separator)
1795 :child (create-label "Below")))
1800 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1801 (let ((tooltips (make-instance 'tooltips)))
1802 (flet ((create-button (label tip-text tip-private)
1803 (let ((button (make-instance 'toggle-button :label label)))
1804 (tooltips-set-tip tooltips button tip-text tip-private)
1806 (make-instance 'v-box
1807 :parent dialog :border-width 10 :spacing 10
1808 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1809 :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")))))
1814 (defvar *ui-description*
1815 '((:menubar "MenuBar"
1820 (:menuitem "SaveAs")
1823 (:menu "PreferencesMenu"
1829 (:menuitem "Square")
1830 (:menuitem "Rectangle")
1834 (:menuitem "About")))
1839 (:toolitem "Logo"))))
1841 (define-toplevel create-ui-manager (window "UI Manager")
1842 (let ((ui (make-instance 'ui-manager)))
1843 (window-add-accel-group window (ui-manager-accel-group ui))
1844 (ui-manager-insert-action-group ui
1845 (make-instance 'action-group :name "Actions"
1846 :action (make-instance 'action :name "FileMenu" :label "_File")
1847 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1848 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1849 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1850 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1851 :action (make-instance 'action
1852 :name "New" :stock-id "gtk-new" :label "_New"
1853 :accelerator "<control>N" :tooltip "Create a new file")
1854 :action (make-instance 'action
1855 :name "Open" :stock-id "gtk-open" :label "_Open"
1856 :accelerator "<control>O" :tooltip "Open a file"
1857 :callback #'create-file-chooser)
1858 :action (make-instance 'action
1859 :name "Save" :stock-id "gtk-save" :label "_Save"
1860 :accelerator "<control>S" :tooltip "Save current file")
1861 :action (make-instance 'action
1862 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1863 :tooltip "Save to a file")
1864 :action (make-instance 'action
1865 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1866 :accelerator "<control>Q" :tooltip "Quit"
1867 :callback (list #'widget-destroy :object window))
1868 :action (make-instance 'action
1869 :name "About" :label "_About"
1870 :accelerator "<control>A" :tooltip "About")
1871 :action (make-instance 'action
1872 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1873 :action (make-instance 'toggle-action
1874 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1875 :accelerator "<control>B" :tooltip "Bold" :active t)
1876 :actions (make-radio-group 'radio-action
1877 '((:name "Red" :value :red :label "_Red"
1878 :accelerator "<control>R" :tooltip "Blood")
1879 (:name "Green" :value :green :label "_Green"
1880 :accelerator "<control>G" :tooltip "Grass" :active t)
1881 (:name "Blue" :value :blue :label "_Blue"
1882 :accelerator "<control>B" :tooltip "Sky"))
1883 #'(lambda (active) (print active)))
1884 :actions (make-radio-group 'radio-action
1885 '((:name "Square" :value :square :label "_Square"
1886 :accelerator "<control>S" :tooltip "Square")
1887 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1888 :accelerator "<control>R" :tooltip "Rectangle")
1889 (:name "Oval" :value :oval :label "_Oval"
1890 :accelerator "<control>O" :tooltip "Egg"))
1891 #'(lambda (active) (print active)))))
1893 (ui-manager-add-ui ui *ui-description*)
1895 (make-instance 'v-box
1898 (ui-manager-get-widget ui "/MenuBar")
1899 :expand nil :fill nil)
1901 (ui-manager-get-widget ui "/ToolBar")
1902 :expand nil :fill nil)
1903 :child (make-instance 'label
1904 :label "Type Ctrl+Q to quit"
1905 :xalign 0.5 :yalign 0.5
1906 :width-request 200 :height-request 200))))
1912 (defun create-main-window (&optional display)
1913 (let* ((button-specs
1914 '(("button box" create-button-box)
1915 ("buttons" create-buttons)
1916 ("calendar" create-calendar)
1917 ("check buttons" create-check-buttons)
1918 ("color selection" create-color-selection)
1919 ("cursors" create-cursors)
1920 ("dialog" create-dialog)
1921 ("entry" create-entry)
1922 ("enxpander" create-expander)
1923 ("file chooser" create-file-chooser)
1924 ("font selection" create-font-selection)
1925 ("handle box" create-handle-box)
1926 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1927 ("icon view" create-icon-view)
1928 ("image" create-image)
1929 ("labels" create-labels)
1930 ("layout" create-layout)
1931 ("list" create-list)
1932 ("menus" create-menus)
1934 ("notebook" create-notebook)
1935 ("panes" create-panes)
1936 ("progress bar" create-progress-bar)
1937 ("radio buttons" create-radio-buttons)
1938 ("range controls" create-range-controls)
1940 ("reparent" create-reparent)
1941 ("rulers" create-rulers)
1942 ;; ("saved position")
1943 ("scrolled windows" create-scrolled-windows)
1944 ("size group" create-size-group)
1945 ("shapes" create-shapes)
1946 ("spinbutton" create-spins)
1947 ("statusbar" create-statusbar)
1948 ("test idle" create-idle-test)
1949 ("test timeout" create-timeout-test)
1950 ("text" create-text)
1951 ("toggle buttons" create-toggle-buttons)
1952 ("toolbar" create-toolbar-window)
1953 ("tooltips" create-tooltips)
1954 ("UI manager" create-ui-manager)))
1956 (main-window (make-instance 'window
1958 :title "testgtk.lisp" :name "main_window"
1959 :default-width 200 :default-height 400
1960 :allow-grow t :allow-shrink nil))
1961 (scrolled-window (make-instance 'scrolled-window
1962 :hscrollbar-policy :automatic
1963 :vscrollbar-policy :automatic
1965 (close-button (make-instance 'button
1966 :stock "gtk-close" :can-default t
1967 :signal (list 'clicked #'widget-destroy :object main-window))))
1969 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1971 (window-icon main-window)
1972 (gdk:pixbuf-add-alpha icon t 254 254 252)))
1975 (make-instance 'v-box
1977 :child-args '(:expand nil)
1978 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1979 :child (list (make-instance 'label :label (clg-version)) :fill nil)
1980 :child (list (make-instance 'label
1982 (format nil "~A (~A)"
1983 (lisp-implementation-type)
1985 (lisp-implementation-version)
1987 (let ((version (lisp-implementation-version)))
1988 (subseq version 0 (position #\sp version))))
1989 ;; The version string in CMUCL is far too long
1990 #+cmu(lisp-implementation-type))
1992 :child (list scrolled-window :expand t)
1993 :child (make-instance 'h-separator)
1994 :child (make-instance 'v-box
1995 :homogeneous nil :spacing 10 :border-width 10
1996 :child close-button))
1999 (make-instance 'v-box
2000 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
2001 :children (mapcar #'(lambda (spec)
2002 (apply #'create-button spec))
2004 (scrolled-window-add-with-viewport scrolled-window content-box))
2006 (widget-grab-focus close-button)
2007 (widget-show-all main-window)
2011 (within-main-loop (create-main-window))