gtk/gtk.demo.lisp

   1 (defpackage :gtk-demo
   2   (:use :cl :gtk :gdk :gobject :iter)
   3   (:export #:demo))
   4
   5 (in-package :gtk-demo)
   6
   7 (defparameter *src-location* (asdf:component-pathname (asdf:find-system :cl-gtk2-gtk)))
   8
   9 (defclass link-text-tag (text-tag)
  10   ()
  11   (:metaclass gobject-class))
  12
  13 (defun make-link-fn-tag (buffer fn)
  14   (let ((tag (make-instance 'link-text-tag :foreground "blue" :underline :single)))
  15     (text-tag-table-add (text-buffer-tag-table buffer) tag)
  16     (connect-signal tag "event"
  17                     (lambda (tag object event it)
  18                       (declare (ignore tag object it))
  19                       (when (and (eq (event-type event) :button-release)
  20                                  (eq (event-button-button event) 1))
  21                         (when fn
  22                           (funcall fn)))))
  23     tag))
  24
  25 (defun get-page (name)
  26   (or (get name 'demo-page)
  27       (get 'page-404 'demo-page)))
  28
  29 (defun (setf get-page) (page name)
  30   (setf (get name 'demo-page) page))
  31
  32 (defmacro def-demo-page ((name &key (index 'index)) &body body)
  33   `(setf (get-page ',name)
  34          '(,@(when index (list `(:p (:link "To main" ,index))))
  35            ,@body)))
  36
  37 (def-demo-page (page-404)
  38   (:p "Non-existent page"))
  39
  40 (def-demo-page (index :index nil)
  41   (:p (:b "cl-gtk2 demonstration"))
  42   (:p "")
  43   (:p "This demo application is a demonstration of what cl-gtk2 can do. You can click on any of blue underlined links to invoke the demonstration.")
  44   (:p "")
  45   (:p "You may try these demos:")
  46   (:ol (:fn "Demonstrates usage of tree store" test-tree-store)
  47        (:fn "Simple test of packing widgets into GtkTable"
  48             table-packing)
  49        (:fn "Test of GtkStatusbar" test-statusbar)
  50        (:fn "Not working example of GtkEntryCompletion"
  51             test-entry-completion)
  52        (:fn "Simple test of non-GObject subclass of GtkWindow"
  53             test-custom-window)
  54        (:fn "Testing progress-bar" test-progress-bar)
  55        (:fn "Simple test of GtkAssistant wizard" test-assistant)
  56        (:fn "Using GtkImage with stock icon" test-image)
  57        (:fn "Test of GtkCalendar" test-calendar)
  58        (:fn "Test of GtkBuilder" test-builder)
  59        (:fn "Test of GtkColorButton" test-color-button)
  60        (:fn "Test of UI Markup" test-ui-markup)
  61        (:fn "Test of scale button with icons" test-scale-button)
  62        (:fn "Testing GtkComboBox" test-combo-box)
  63        (:fn "Advanced demo: show s-expression tree structure"
  64             demo-treeview-tree)
  65        (:fn "Test of child-property usage" test-box-child-property)
  66        (:fn "Demonstrates usage of list store" test-list-store)
  67        (:fn "Test various gdk primitives" test-gdk)
  68        (:fn "Test GtkNotebook" test-notebook)
  69        (:fn "More advanced example: text editor with ability to evaluate lisp expressions"
  70             demo-text-editor)
  71        (:fn "(not completed)" test-pixbuf)
  72        (:fn "Testing GtkTextEntry" test-entry)
  73        (:fn "Test of treeview with CL-GTK2-GTK:ARRAY-LIST-STORE"
  74             test-treeview-list)
  75        (:fn "Test of GtkFileChooser" test-file-chooser)
  76        (:fn "Test of GtkColorSelection" test-color-selection)
  77        (:fn "Test of GtkTextView" test-text-view)
  78        (:fn "A simple test of 'on-expose' event" test)
  79        (:fn "Show slots of a given class" demo-class-browser)
  80        (:fn "Testing GtkUIManager" test-ui-manager)
  81        (:fn "GtkFontChooser" test-font-chooser)))
  82
  83 (defun fill-demo-text-buffer (buffer text-view &optional (page 'index))
  84   (declare (ignorable text-view))
  85   (setf (text-buffer-tag-table buffer) (make-instance 'text-tag-table))
  86   (setf (text-buffer-text buffer) "")
  87   (text-tag-table-add (text-buffer-tag-table buffer) (make-instance 'text-tag :name "bold" :weight 700))
  88   (labels ((insert-text (text)
  89              (text-buffer-insert buffer text))
  90            (insert-link (text fn)
  91              (let ((offset (text-iter-offset (text-buffer-get-end-iter buffer))))
  92                (text-buffer-insert buffer text)
  93                (text-buffer-apply-tag buffer (make-link-fn-tag buffer fn)
  94                                       (text-buffer-get-iter-at-offset buffer offset)
  95                                       (text-buffer-get-end-iter buffer))))
  96            (insert-newline ()
  97              (text-buffer-insert buffer (format nil "~%")))
  98            (process-paragraph (node)
  99              (map nil #'process (rest node))
 100              (insert-newline))
 101            (process-link (node)
 102              (insert-link (second node) (lambda () (fill-demo-text-buffer buffer text-view (third node)))))
 103            (process-fn (node)
 104              (insert-link (second node) (third node)))
 105            (process-ul (node)
 106              (iter (for n in (rest node))
 107                    (for i from 1)
 108                    (insert-text "* ")
 109                    (process n)
 110                    (insert-newline)))
 111            (process-ol (node)
 112              (iter (for n in (rest node))
 113                    (for i from 1)
 114                    (insert-text (format nil "~A. " i))
 115                    (process n)
 116                    (insert-newline)))
 117            (process-bold (node)
 118              (let ((offset (text-iter-offset (text-buffer-get-end-iter buffer))))
 119                (map nil #'process (rest node))
 120                (text-buffer-apply-tag buffer "bold" (text-buffer-get-iter-at-offset buffer offset) (text-buffer-get-end-iter buffer))))
 121            (process (node)
 122              (cond
 123                ((stringp node) (insert-text node))
 124                ((and (listp node) (eq (car node) :p)) (process-paragraph node))
 125                ((and (listp node) (eq (car node) :link)) (process-link node))
 126                ((and (listp node) (eq (car node) :fn)) (process-fn node))
 127                ((and (listp node) (eq (car node) :ul)) (process-ul node))
 128                ((and (listp node) (eq (car node) :ol)) (process-ol node))
 129                ((and (listp node) (eq (car node) :b)) (process-bold node))
 130                ((listp node) (map nil #'process node))
 131                (t (error "Do not know how to proceed")))))
 132     (process (get-page page))))
 133
 134 (defun make-demo-text-buffer (text-view)
 135   (let ((buffer (make-instance 'text-buffer)))
 136     (fill-demo-text-buffer buffer text-view)
 137     buffer))
 138
 139 (defvar *active-tag* nil)
 140
 141 (defun tv-motion-notify (tv event)
 142   (multiple-value-bind (x y)
 143       (text-view-window-to-buffer-coords tv :text
 144                                          (round (event-motion-x event)) (round (event-motion-y event)))
 145     (let ((it (text-view-get-iter-at-location tv x y)))
 146       (if it
 147           (let ((tags (text-iter-tags it)))
 148             (if tags
 149                 (loop
 150                    for tag in tags
 151                    when (typep tag 'link-text-tag)
 152                    do (progn
 153                         (when *active-tag*
 154                           (setf (text-tag-foreground *active-tag*) "blue"
 155                                 *active-tag* nil))
 156                         (setf (gdk-window-cursor (text-view-get-window tv :text))
 157                               (cursor-new-for-display (drawable-display (text-view-get-window tv :text))
 158                                                       :hand2)
 159                               *active-tag* tag
 160                               (text-tag-foreground *active-tag*) "red")))
 161                 (progn
 162                   (setf (gdk-window-cursor (text-view-get-window tv :text)) nil)
 163                   (when *active-tag*
 164                     (setf (text-tag-foreground *active-tag*) "blue"
 165                           *active-tag* nil)))))
 166           (progn
 167             (setf (gdk-window-cursor (text-view-get-window tv :text)) nil)
 168             (when *active-tag*
 169               (setf (text-tag-foreground *active-tag*) "blue"
 170                     *active-tag* nil)))))))
 171
 172 (defun make-demo-text-view ()
 173   (let ((tv (make-instance 'text-view :editable nil :cursor-visible nil :wrap-mode :word :pixels-below-lines 1 :left-margin 5 :right-margin 5)))
 174     (setf (text-view-buffer tv)
 175           (make-demo-text-buffer tv))
 176     (connect-signal tv "motion-notify-event" #'tv-motion-notify)
 177     tv))
 178
 179 (defun demo ()
 180   (within-main-loop
 181     (let-ui
 182         (gtk-window
 183          :var w
 184          :title "Gtk+ demo for Lisp"
 185          :window-position :center
 186          :default-width 500
 187          :default-height 500
 188          (scrolled-window
 189           :hscrollbar-policy :automatic
 190           :vscrollbar-policy :automatic
 191           (:expr (make-demo-text-view))))
 192       (widget-show w))))
 193
 194 (defun test ()
 195   "A simple test of 'on-expose' event"
 196   (within-main-loop
 197     (let ((window (make-instance 'gtk-window :type :toplevel))
 198           (area (make-instance 'drawing-area))
 199           x y)
 200       (container-add window area)
 201       (connect-signal window "destroy" (lambda (widget)
 202                                          (declare (ignore widget))
 203                                          (leave-gtk-main)))
 204       (connect-signal area "motion-notify-event"
 205                       (lambda (widget event)
 206                         (declare (ignore widget))
 207                         (setf x (event-motion-x event)
 208                               y (event-motion-y event))
 209                         (widget-queue-draw window)))
 210       (connect-signal area "expose-event"
 211                       (lambda (widget event)
 212                         (declare (ignore widget event))
 213                         (let* ((gdk-window (widget-window area))
 214                                (gc (graphics-context-new gdk-window))
 215                                (layout (widget-create-pango-layout area (format nil "X: ~F~%Y: ~F" x y))))
 216                           (draw-layout gdk-window gc 0 0 layout)
 217                           (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 0 :blue 0))
 218                           (multiple-value-bind (x y) (drawable-get-size gdk-window)
 219                             (draw-line gdk-window gc 0 0 x y)))))
 220       (connect-signal area "realize"
 221                       (lambda (widget)
 222                         (declare (ignore widget))
 223                         (pushnew :pointer-motion-mask (gdk-window-events (widget-window area)))))
 224       (connect-signal area "configure-event"
 225                       (lambda (widget event)
 226                         (declare (ignore widget event))
 227                         (widget-queue-draw area)))
 228       (widget-show window))))
 229
 230 (defun test-entry ()
 231   "Testing GtkTextEntry"
 232   (within-main-loop
 233     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing entry" :border-width 10))
 234            (box (make-instance 'v-box))
 235            (entry (make-instance 'entry))
 236            (button (make-instance 'button :label "OK"))
 237            (text-buffer (make-instance 'text-buffer))
 238            (text-view (make-instance 'text-view :buffer text-buffer))
 239            (button-select (make-instance 'button :label "Select"))
 240            (button-insert (make-instance 'button :label "Insert")))
 241       (box-pack-start box (make-instance 'label :label "Enter <b>anything</b> you wish:" :use-markup t) :expand nil)
 242       (box-pack-start box entry :expand nil)
 243       (box-pack-start box button :expand nil)
 244       (box-pack-start box button-select :expand nil)
 245       (box-pack-start box button-insert :expand nil)
 246       (let* ((w (make-instance 'scrolled-window)))
 247         (box-pack-start box w)
 248         (container-add w text-view))
 249       (container-add window box)
 250       (connect-signal window "destroy" (lambda (widget) (declare (ignore widget)) (leave-gtk-main)))
 251       (connect-signal window "delete-event" (lambda (widget event)
 252                                               (declare (ignore widget event))
 253                                               (let ((dlg (make-instance 'message-dialog
 254                                                                         :text "Are you sure?"
 255                                                                         :buttons :yes-no)))
 256                                                 (let ((response (dialog-run dlg)))
 257                                                   (object-destroy dlg)
 258                                                   (not (eq :yes response))))))
 259       (connect-signal button "clicked" (lambda (button)
 260                                          (declare (ignore button))
 261                                          (setf (text-buffer-text text-buffer)
 262                                                (format nil "~A~%~A" (text-buffer-text text-buffer) (entry-text entry))
 263                                                (entry-text entry) "")))
 264       (connect-signal button-select "clicked" (lambda (button)
 265                                                 (declare (ignore button))
 266                                                 (editable-select-region entry 5 10)))
 267       (connect-signal button-insert "clicked" (lambda (button)
 268                                                 (declare (ignore button))
 269                                                 (editable-insert-text entry "hello" 2)))
 270       (widget-show window))))
 271
 272 (defun table-packing ()
 273   "Simple test of packing widgets into GtkTable"
 274   (within-main-loop
 275     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Table packing" :border-width 20))
 276            (table (make-instance 'table :n-rows 2 :n-columns 2 :homogeneous t))
 277            (button-1 (make-instance 'button :label "Button 1"))
 278            (button-2 (make-instance 'button :label "Button 2"))
 279            (button-q (make-instance 'button :label "Quit")))
 280       (container-add window table)
 281       (table-attach table button-1 0 1 0 1)
 282       (table-attach table button-2 1 2 0 1)
 283       (table-attach table button-q 0 2 1 2)
 284       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 285       (connect-signal button-q "clicked" (lambda (b) (declare (ignore b)) (object-destroy window)))
 286       (widget-show window))))
 287
 288 (defun test-pixbuf ()
 289   "(not completed)"
 290   (within-main-loop
 291     (let* ((window (make-instance 'gtk-window :title "Test pixbuf" :width-request 600 :height-request 240))
 292            (vbox (make-instance 'v-box))
 293            (eventbox (make-instance 'event-box))
 294            (vbox-1 (make-instance 'v-box)))
 295       (container-add window vbox)
 296       (box-pack-start vbox (make-instance 'label :text "Placing bg image" :font "Times New Roman Italic 10" :color "#00f" :height-request 40))
 297       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 298       (box-pack-start vbox eventbox)
 299       (container-add eventbox vbox-1)
 300       (box-pack-start vbox-1 (make-instance 'label :text "This is the eventbox"))
 301       (box-pack-start vbox-1 (make-instance 'label :text "The green ball is the bg"))
 302       (widget-show window))))
 303
 304 (defun test-image ()
 305   "Using GtkImage with stock icon"
 306   (within-main-loop
 307     (let* ((window (make-instance 'gtk-window :title "Test images"))
 308            (image (make-instance 'image :icon-name "applications-development" :icon-size 6)))
 309       (container-add window image)
 310       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 311       (widget-show window))))
 312
 313 (defun test-progress-bar ()
 314   "Testing progress-bar"
 315   (within-main-loop
 316     (let* ((window (make-instance 'gtk-window :title "Test progress bar"))
 317            (v-box (make-instance 'v-box))
 318            (p-bar (make-instance 'progress-bar :test "A process"))
 319            (button-pulse (make-instance 'button :label "Pulse"))
 320            (button-set (make-instance 'button :label "Set"))
 321            (entry (make-instance 'entry)))
 322       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 323       (container-add window v-box)
 324       (box-pack-start v-box p-bar)
 325       (box-pack-start v-box button-pulse)
 326       (box-pack-start v-box button-set)
 327       (box-pack-start v-box entry)
 328       (connect-signal button-pulse "clicked" (lambda (w) (declare (ignore w)) (progress-bar-pulse p-bar)))
 329       (connect-signal button-set "clicked" (lambda (w)
 330                                              (declare (ignore w))
 331                                              (setf (progress-bar-fraction p-bar)
 332                                                    (coerce (read-from-string (entry-text entry)) 'real))))
 333       (widget-show window))))
 334
 335 (defun test-statusbar ()
 336   "Test of GtkStatusbar"
 337   (within-main-loop
 338     (let* ((window (make-instance 'gtk-window :title "Text status bar"))
 339            (v-box (make-instance 'v-box))
 340            (h-box (make-instance 'h-box))
 341            (label (make-instance 'label :label "Test of status bar" :xalign 0.5 :yalign 0.5))
 342            (statusbar (make-instance 'statusbar :has-resize-grip t))
 343            (button-push (make-instance 'button :label "Push"))
 344            (button-pop (make-instance 'button :label "Pop"))
 345            (entry (make-instance 'entry))
 346            (icon (make-instance 'status-icon :icon-name "applications-development")))
 347       (set-status-icon-tooltip icon "An icon from lisp program")
 348       (connect-signal window "destroy" (lambda (w)
 349                                          (declare (ignore w))
 350                                          #+ (or) (setf (status-icon-visible icon) nil)
 351                                          (leave-gtk-main)))
 352       (connect-signal button-push "clicked" (lambda (b)
 353                                               (declare (ignore b))
 354                                               (statusbar-push statusbar "lisp-prog" (entry-text entry))))
 355       (connect-signal button-pop "clicked" (lambda (b)
 356                                              (declare (ignore b))
 357                                              (statusbar-pop statusbar "lisp-prog")))
 358       (connect-signal icon "activate" (lambda (i)
 359                                         (declare (ignore i))
 360                                         (let ((message-dialog (make-instance 'message-dialog
 361                                                                              :buttons :ok
 362                                                                              :text "You clicked on icon!")))
 363                                           (dialog-run message-dialog)
 364                                           (object-destroy message-dialog))))
 365       (container-add window v-box)
 366       (box-pack-start v-box h-box :expand nil)
 367       (box-pack-start h-box entry)
 368       (box-pack-start h-box button-push :expand nil)
 369       (box-pack-start h-box button-pop :expand nil)
 370       (box-pack-start v-box label)
 371       (box-pack-start v-box statusbar :expand nil)
 372       (widget-show window)
 373       (setf (status-icon-screen icon) (gtk-window-screen window)))))
 374
 375 (defun test-scale-button ()
 376   "Test of scale button with icons"
 377   (within-main-loop
 378     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing scale button"))
 379            (button (make-instance 'scale-button :icons (list "media-seek-backward" "media-seek-forward" "media-playback-stop" "media-playback-start") :adjustment (make-instance 'adjustment :lower -40 :upper 50 :value 20))))
 380       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 381       (container-add window button)
 382       (widget-show window))))
 383
 384 (defun test-text-view ()
 385   "Test of GtkTextView"
 386   (within-main-loop
 387     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing text view" :width-request 400 :height-request 300))
 388            (button (make-instance 'button :label "Do"))
 389            (button-insert (make-instance 'button :label "Insert a button!"))
 390            (bold-btn (make-instance 'button :label "Bold"))
 391            (buffer (make-instance 'text-buffer :text "Some text buffer with some text inside"))
 392            (v (make-instance 'text-view :buffer buffer :wrap-mode :word))
 393            (box (make-instance 'v-box))
 394            (scrolled (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic)))
 395       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 396       (connect-signal button "clicked" (lambda (b)
 397                                          (declare (ignore b))
 398                                          (multiple-value-bind (i1 i2) (text-buffer-get-selection-bounds buffer)
 399                                            (when (and i1 i2)
 400                                              (let* ((i1 i1) (i2 i2)
 401                                                     (dialog (make-instance 'message-dialog :buttons :ok)))
 402                                                (setf (message-dialog-text dialog)
 403                                                      (format nil "selection: from (~A,~A) to (~A,~A)"
 404                                                              (text-iter-line i1) (text-iter-line-offset i1)
 405                                                              (text-iter-line i2) (text-iter-line-offset i2)))
 406                                                (dialog-run dialog)
 407                                                (object-destroy dialog))))))
 408       (connect-signal bold-btn "clicked" (Lambda (b)
 409                                            (declare (ignore b))
 410                                            (multiple-value-bind (start end) (text-buffer-get-selection-bounds buffer)
 411                                              (when (and start end)
 412                                                (let* ((start start)
 413                                                       (end end)
 414                                                       (tag (text-tag-table-lookup (text-buffer-tag-table buffer) "bold")))
 415                                                  (if (text-iter-has-tag start tag)
 416                                                      (text-buffer-remove-tag buffer tag start end)
 417                                                      (text-buffer-apply-tag buffer tag start end)))))))
 418       (connect-signal button-insert "clicked" (lambda (b)
 419                                                 (declare (ignore b))
 420                                                 (let* ((iter (text-buffer-get-iter-at-mark buffer (text-buffer-get-mark buffer "insert")))
 421                                                        (anchor (text-buffer-insert-child-anchor buffer iter))
 422                                                        (button (make-instance 'button :label "A button!")))
 423                                                   (widget-show button)
 424                                                   (text-view-add-child-at-anchor v button anchor))))
 425       (let ((tag (make-instance 'text-tag :name "bold" :weight 700)))
 426         (text-tag-table-add (text-buffer-tag-table buffer) tag)
 427         (connect-signal tag "event"
 428                         (lambda (tag object event iter)
 429                           (declare (ignore tag object iter))
 430                           (when (eq (event-type event) :button-release)
 431                             (let ((dlg (make-instance 'message-dialog :text "You clicked on bold text." :buttons :ok)))
 432                               (dialog-run dlg)
 433                               (object-destroy dlg))))))
 434       (container-add window box)
 435       (container-add scrolled v)
 436       (box-pack-start box button :expand nil)
 437       (box-pack-start box button-insert :expand nil)
 438       (box-pack-start box bold-btn :expand nil)
 439       (box-pack-start box scrolled)
 440       (widget-show window))))
 441
 442 (defun demo-code-editor ()
 443   "(unfinished)"
 444   (within-main-loop
 445     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Code editor" :width-request 400 :height-request 400 :window-position :center))
 446            (scrolled (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
 447            (buffer (make-instance 'text-buffer))
 448            (view (make-instance 'text-view :buffer buffer)))
 449       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 450       (container-add window scrolled)
 451       (container-add scrolled view)
 452       (widget-show window)
 453       (connect-signal buffer "insert-text" (lambda (buffer location text len)
 454                                              (let* ((buffer buffer)
 455                                                     (location location))
 456                                                (format t "~A~%" (list buffer location text len))))))))
 457
 458 (defstruct tvi title value)
 459
 460 (defun test-treeview-list ()
 461   "Test of treeview with CL-GTK2-GTK:ARRAY-LIST-STORE"
 462   (within-main-loop
 463     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (list)"))
 464            (model (make-instance 'array-list-store))
 465            (scroll (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
 466            (tv (make-instance 'tree-view :headers-visible t :width-request 100 :height-request 400 :rules-hint t))
 467            (h-box (make-instance 'h-box))
 468            (v-box (make-instance 'v-box))
 469            (title-entry (make-instance 'entry))
 470            (value-entry (make-instance 'entry))
 471            (button (make-instance 'button :label "Add")))
 472       (store-add-column model "gchararray" #'tvi-title)
 473       (store-add-column model "gint" #'tvi-value)
 474       (store-add-item model (make-tvi :title "Monday" :value 1))
 475       (store-add-item model (make-tvi :title "Tuesday" :value 2))
 476       (store-add-item model (make-tvi :title "Wednesday" :value 3))
 477       (store-add-item model (make-tvi :title "Thursday" :value 4))
 478       (store-add-item model (make-tvi :title "Friday" :value 5))
 479       (store-add-item model (make-tvi :title "Saturday" :value 6))
 480       (store-add-item model (make-tvi :title "Sunday" :value 7))
 481       (setf (tree-view-model tv) model (tree-view-tooltip-column tv) 0)
 482       (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 483       (gobject:connect-signal button "clicked" (lambda (b)
 484                                                  (declare (ignore b))
 485                                                  (store-add-item model (make-tvi :title (entry-text title-entry)
 486                                                                                  :value (or (parse-integer (entry-text value-entry)
 487                                                                                                            :junk-allowed t)
 488                                                                                             0)))))
 489       (connect-signal tv "row-activated" (lambda (tv path column)
 490                                            (declare (ignore tv column))
 491                                            (format t "You clicked on row ~A~%" (tree-path-indices path))))
 492       (container-add window v-box)
 493       (box-pack-start v-box h-box :expand nil)
 494       (box-pack-start h-box title-entry :expand nil)
 495       (box-pack-start h-box value-entry :expand nil)
 496       (box-pack-start h-box button :expand nil)
 497       (box-pack-start v-box scroll)
 498       (container-add scroll tv)
 499       (let ((column (make-instance 'tree-view-column :title "Title" :sort-column-id 0))
 500             (renderer (make-instance 'cell-renderer-text :text "A text")))
 501         (tree-view-column-pack-start column renderer)
 502         (tree-view-column-add-attribute column renderer "text" 0)
 503         (tree-view-append-column tv column)
 504         (print (tree-view-column-tree-view column))
 505         (print (tree-view-column-cell-renderers column)))
 506       (let ((column (make-instance 'tree-view-column :title "Value"))
 507             (renderer (make-instance 'cell-renderer-text :text "A text")))
 508         (tree-view-column-pack-start column renderer)
 509         (tree-view-column-add-attribute column renderer "text" 1)
 510         (tree-view-append-column tv column)
 511         (print (tree-view-column-tree-view column))
 512         (print (tree-view-column-cell-renderers column)))
 513       (widget-show window))))
 514
 515 (defun test-combo-box ()
 516   "Testing GtkComboBox"
 517   (within-main-loop
 518     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (list)"))
 519            (model (make-instance 'array-list-store))
 520            (combo-box (make-instance 'combo-box :model model))
 521            (h-box (make-instance 'h-box))
 522            (v-box (make-instance 'v-box))
 523            (title-entry (make-instance 'entry))
 524            (value-entry (make-instance 'entry))
 525            (button (make-instance 'button :label "Add")))
 526       (store-add-column model "gchararray" #'tvi-title)
 527       (store-add-column model "gint" #'tvi-value)
 528       (store-add-item model (make-tvi :title "Monday" :value 1))
 529       (store-add-item model (make-tvi :title "Tuesday" :value 2))
 530       (store-add-item model (make-tvi :title "Wednesday" :value 3))
 531       (store-add-item model (make-tvi :title "Thursday" :value 4))
 532       (store-add-item model (make-tvi :title "Friday" :value 5))
 533       (store-add-item model (make-tvi :title "Saturday" :value 6))
 534       (store-add-item model (make-tvi :title "Sunday" :value 7))
 535       (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 536       (gobject:connect-signal button "clicked" (lambda (b)
 537                                                  (declare (ignore b))
 538                                                  (store-add-item model (make-tvi :title (entry-text title-entry)
 539                                                                                  :value (or (parse-integer (entry-text value-entry)
 540                                                                                                            :junk-allowed t)
 541                                                                                             0)))))
 542       (connect-signal combo-box "changed" (lambda (c)
 543                                             (declare (ignore c))
 544                                             (format t "You clicked on row ~A~%" (combo-box-active combo-box))))
 545       (container-add window v-box)
 546       (box-pack-start v-box h-box :expand nil)
 547       (box-pack-start h-box title-entry :expand nil)
 548       (box-pack-start h-box value-entry :expand nil)
 549       (box-pack-start h-box button :expand nil)
 550       (box-pack-start v-box combo-box)
 551       (let ((renderer (make-instance 'cell-renderer-text :text "A text")))
 552         (cell-layout-pack-start combo-box renderer :expand t)
 553         (cell-layout-add-attribute combo-box renderer "text" 0))
 554       (let ((renderer (make-instance 'cell-renderer-text :text "A number")))
 555         (cell-layout-pack-start combo-box renderer :expand nil)
 556         (cell-layout-add-attribute combo-box renderer "text" 1))
 557       (widget-show window))))
 558
 559 (defun test-ui-manager ()
 560   "Testing GtkUIManager"
 561   (within-main-loop
 562     (let* ((window (make-instance 'gtk-window :type :toplevel :title "UI Manager" :default-width 200 :default-height 100 :window-position :center))
 563            (ui-manager (make-instance 'ui-manager))
 564            (print-confirmation t))
 565       (ui-manager-add-ui-from-string ui-manager
 566                                      "
 567 <ui>
 568   <toolbar action='toolbar1'>
 569       <separator/>
 570       <toolitem name='Left' action='justify-left'/>
 571       <toolitem name='Center' action='justify-center'/>
 572       <toolitem name='Right' action='justify-right'/>
 573       <toolitem name='Zoom in' action='zoom-in' />
 574       <toolitem name='print-confirm' action='print-confirm' />
 575       <separator/>
 576   </toolbar>
 577 </ui>")
 578       (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 579       (iter (with fn = (lambda (action) (when print-confirmation (format t "Action ~A with name ~A activated~%" action (action-name action)))))
 580             (with action-group = (make-instance 'action-group :name "Actions"))
 581             (finally (let ((a (make-instance 'toggle-action :name "print-confirm" :label "Print" :stock-id "gtk-print-report" :active t)))
 582                        (connect-signal a "toggled" (lambda (action) (setf print-confirmation (toggle-action-active action))))
 583                        (action-group-add-action action-group a))
 584                      (ui-manager-insert-action-group ui-manager action-group 0))
 585             (for (name stock-id) in '(("justify-left" "gtk-justify-left")
 586                                       ("justify-center" "gtk-justify-center")
 587                                       ("justify-right" "gtk-justify-right")
 588                                       ("zoom-in" "gtk-zoom-in")))
 589             (for action = (make-instance 'action :name name :stock-id stock-id))
 590             (connect-signal action "activate" fn)
 591             (action-group-add-action action-group action))
 592       (let ((widget (ui-manager-widget ui-manager "/toolbar1")))
 593         (when widget
 594           (container-add window widget)))
 595       (widget-show window))))
 596
 597 (defun test-color-button ()
 598   "Test of GtkColorButton"
 599   (within-main-loop
 600     (let ((window (make-instance 'gtk-window :title "Color button" :type :toplevel :window-position :center :width-request 100 :height-request 100))
 601           (button (make-instance 'color-button :title "Color button")))
 602       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 603       (connect-signal button "color-set" (lambda (b)
 604                                            (declare (ignore b))
 605                                            (format t "Chose color ~A~%" (color-button-color button))))
 606       (container-add window button)
 607       (widget-show window))))
 608
 609 (defun test-color-selection ()
 610   "Test of GtkColorSelection"
 611   (within-main-loop
 612     (let ((window (make-instance 'gtk-window :title "Color selection" :type :toplevel :window-position :center))
 613           (selection (make-instance 'color-selection :has-opacity-control t)))
 614       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 615       (connect-signal selection "color-changed" (lambda (s) (declare (ignore s)) (unless (color-selection-adjusting-p selection) (format t "color: ~A~%" (color-selection-current-color selection)))))
 616       (container-add window selection)
 617       (widget-show window))))
 618
 619 (defun test-file-chooser ()
 620   "Test of GtkFileChooser"
 621   (within-main-loop
 622     (let ((window (make-instance 'gtk-window :title "file chooser" :type :toplevel :window-position :center :default-width 100 :default-height 100))
 623           (v-box (make-instance 'v-box))
 624           (button (make-instance 'file-chooser-button :action :open))
 625           (b (make-instance 'button :label "Choose for save" :stock-id "gtk-save")))
 626       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 627       (connect-signal button "file-set" (lambda (b) (declare (ignore b)) (format t "File set: ~A~%" (file-chooser-filename button))))
 628       (connect-signal b "clicked" (lambda (b)
 629                                     (declare (ignore b))
 630                                     (let ((d (make-instance 'file-chooser-dialog :action :save :title "Choose file to save")))
 631                                       (dialog-add-button d "gtk-save" :accept)
 632                                       (dialog-add-button d "gtk-cancel" :cancel)
 633                                       (when (eq (dialog-run d) :accept)
 634                                         (format t "saved to file ~A~%" (file-chooser-filename d)))
 635                                       (object-destroy d))))
 636       (container-add window v-box)
 637       (box-pack-start v-box button)
 638       (box-pack-start v-box b)
 639       (widget-show window))))
 640
 641 (defun test-font-chooser ()
 642   "GtkFontChooser"
 643   (within-main-loop
 644     (let ((window (make-instance 'gtk-window :title "fonts" :type :toplevel :window-position :center :default-width 100 :default-height 100))
 645           (v-box (make-instance 'v-box))
 646           (button (make-instance 'font-button :title "Choose font" :font-name "Sans 10")))
 647       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 648       (connect-signal button "font-set" (lambda (b) (declare (ignore b)) (format t "Chose font ~A~%" (font-button-font-name button))))
 649       (container-add window v-box)
 650       (box-pack-start v-box button)
 651       (widget-show window))))
 652
 653 (defun test-notebook ()
 654   "Test GtkNotebook"
 655   (within-main-loop
 656     (let ((window (make-instance 'gtk-window :title "Notebook" :type :toplevel :window-position :center :default-width 100 :default-height 100))
 657           (expander (make-instance 'expander :expanded t :label "notebook"))
 658           (notebook (make-instance 'notebook :enable-popup t)))
 659       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 660       (iter (for i from 0 to 5)
 661             (for page = (make-instance 'label :label (format nil "Label for page ~A" i)))
 662             (for tab-label = (make-instance 'label :label (format nil "Tab ~A" i)))
 663             (for tab-button = (make-instance 'button
 664                                              :image (make-instance 'image :stock "gtk-close" :icon-size 1)
 665                                              :relief :none))
 666             (connect-signal tab-button "clicked"
 667                             (let ((page page))
 668                               (lambda (button)
 669                                 (declare (ignore button))
 670                                 (format t "Removing page ~A~%" page)
 671                                 (notebook-remove-page notebook page))))
 672             (for tab-hbox = (make-instance 'h-box))
 673             (box-pack-start tab-hbox tab-label)
 674             (box-pack-start tab-hbox tab-button)
 675             (widget-show tab-hbox)
 676             (notebook-add-page notebook page tab-hbox))
 677       (container-add window expander)
 678       (container-add expander notebook)
 679       (widget-show window))))
 680
 681 (defun calendar-detail (calendar year month day)
 682   (declare (ignore calendar year month))
 683   (when (= day 23)
 684     "!"))
 685
 686 (defun test-calendar ()
 687   "Test of GtkCalendar"
 688   (within-main-loop
 689     (let ((window (make-instance 'gtk-window :title "Calendar" :type :toplevel :window-position :center :default-width 100 :default-height 100))
 690           (calendar (make-instance 'calendar :detail-function #'calendar-detail)))
 691       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 692       (connect-signal calendar "day-selected" (lambda (c) (declare (ignore c)) (format t "selected: year ~A month ~A day ~A~%"
 693                                                                                        (calendar-year calendar)
 694                                                                                        (calendar-month calendar)
 695                                                                                        (calendar-day calendar))))
 696       (container-add window calendar)
 697       (widget-show window))))
 698
 699 (defun test-box-child-property ()
 700   "Test of child-property usage"
 701   (within-main-loop
 702     (let ((window (make-instance 'gtk-window :title "Text box child property" :type :toplevel :window-position :center :width-request 200 :height-request 200))
 703           (box (make-instance 'h-box))
 704           (button (make-instance 'toggle-button :active t :label "Expand")))
 705       (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 706       (connect-signal button "toggled" (lambda (b) (declare (ignore b)) (setf (box-child-expand box button) (toggle-button-active button))))
 707       (container-add window box)
 708       (box-pack-start box button)
 709       (widget-show window))))
 710
 711 (defun test-builder ()
 712   "Test of GtkBuilder"
 713   (within-main-loop
 714     (let ((builder (make-instance 'builder)))
 715       (builder-add-from-file builder (namestring (merge-pathnames "demo/demo1.ui" *src-location*)))
 716       (let ((text-view (builder-get-object builder "textview1"))
 717             (c 0))
 718         (builder-connect-signals-simple builder `(("toolbutton1_clicked_cb" ,(lambda (b)
 719                                                                                      (declare (ignore b))
 720                                                                                      #+nil(print (current-event))
 721                                                                                      (setf (text-buffer-text (text-view-buffer text-view))
 722                                                                                            (format nil "Clicked ~A times~%" (incf c)))
 723                                                                                      (statusbar-pop (builder-get-object builder "statusbar1")
 724                                                                                                     "times")
 725                                                                                      (statusbar-push (builder-get-object builder "statusbar1")
 726                                                                                                      "times"
 727                                                                                                      (format nil "~A times" c))))
 728                                                   ("quit_cb" ,(lambda (&rest args)
 729                                                                       (print args)
 730                                                                       (object-destroy (builder-get-object builder "window1"))))
 731                                                   ("about_cb" ,(lambda (&rest args)
 732                                                                        (print args)
 733                                                                        (let ((d (make-instance 'about-dialog
 734                                                                                                :program-name "GtkBuilder text"
 735                                                                                                :version "0.00001"
 736                                                                                                :authors '("Dmitry Kalyanov")
 737                                                                                                :logo-icon-name "gtk-apply")))
 738                                                                          (dialog-run d)
 739                                                                          (object-destroy d)))))))
 740       (connect-signal (builder-get-object builder "window1") "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 741       (statusbar-push (builder-get-object builder "statusbar1") "times" "0 times")
 742       (widget-show (builder-get-object builder "window1")))))
 743
 744 (defun read-text-file (file-name)
 745   (with-output-to-string (str)
 746     (with-open-file (file file-name)
 747       (loop
 748          for line = (read-line file nil nil)
 749          while line
 750          do (fresh-line str)
 751          do (write-string line str)))))
 752
 753 (defun demo-text-editor ()
 754   "More advanced example: text editor with ability to evaluate lisp expressions"
 755   (within-main-loop
 756     (let* ((builder (let ((builder (make-instance 'builder)))
 757                       (builder-add-from-file builder (namestring (merge-pathnames "demo/text-editor.ui" *src-location*)))
 758                       builder))
 759            (window (builder-get-object builder "window1"))
 760            (text-view (builder-get-object builder "textview1"))
 761            (statusbar (builder-get-object builder "statusbar1"))
 762            (file-name nil)
 763            (modified-p t))
 764       (statusbar-push statusbar "filename" "Untitled *")
 765       (labels ((set-properties ()
 766                  (statusbar-pop statusbar "filename")
 767                  (statusbar-push statusbar "filename" (format nil "~A~:[~; *~]" (or file-name "Untitled") modified-p)))
 768                (new (&rest args) (declare (ignore args))
 769                     (setf file-name nil
 770                           modified-p t
 771                           (text-buffer-text (text-view-buffer text-view)) "")
 772                     (set-properties))
 773                (cb-open (&rest args) (declare (ignore args))
 774                         (let ((d (make-instance 'file-chooser-dialog :action :open :title "Open file")))
 775                           (when file-name (setf (file-chooser-filename d) file-name))
 776                           (dialog-add-button d "gtk-open" :accept)
 777                           (dialog-add-button d "gtk-cancel" :cancel)
 778                           (when (eq :accept (dialog-run d))
 779                             (setf file-name (file-chooser-filename d)
 780                                   (text-buffer-text (text-view-buffer text-view)) (read-text-file file-name)
 781                                   modified-p nil)
 782                             (set-properties))
 783                           (object-destroy d)))
 784                (save (&rest args) (declare (ignore args))
 785                      (if file-name
 786                          (progn
 787                            (with-open-file (file file-name :direction :output :if-exists :supersede)
 788                              (write-string (text-buffer-text (text-view-buffer text-view)) file))
 789                            (setf modified-p nil)
 790                            (set-properties))
 791                          (save-as)))
 792                (save-as (&rest args) (declare (ignore args))
 793                         (let ((d (make-instance 'file-chooser-dialog :action :save :title "Save file")))
 794                           (when file-name (setf (file-chooser-filename d) file-name))
 795                           (dialog-add-button d "gtk-save" :accept)
 796                           (dialog-add-button d "gtk-cancel" :cancel)
 797                           (if (eq :accept (dialog-run d))
 798                               (progn
 799                                 (setf file-name (file-chooser-filename d))
 800                                 (object-destroy d)
 801                                 (save))
 802                               (object-destroy d))))
 803                (cut (&rest args) (declare (ignore args))
 804                     (text-buffer-cut-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD") t))
 805                (copy (&rest args) (declare (ignore args))
 806                      (text-buffer-copy-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD")))
 807                (paste (&rest args) (declare (ignore args))
 808                       (text-buffer-paste-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD")))
 809                (cb-delete (&rest args) (declare (ignore args))
 810                           (let ((buffer (text-view-buffer text-view)))
 811                             (multiple-value-bind (i1 i2) (text-buffer-get-selection-bounds buffer)
 812                               (when (and i1 i2)
 813                                 (text-buffer-delete buffer i1 i2)))))
 814                (about (&rest args) (declare (ignore args))
 815                       (let ((d (make-instance 'about-dialog
 816                                               :program-name "Lisp Gtk+ Binding Demo Text Editor"
 817                                               :version (format nil "0.0.0.1 ~A" #\GREEK_SMALL_LETTER_ALPHA)
 818                                               :authors '("Kalyanov Dmitry")
 819                                               :license "Public Domain"
 820                                               :logo-icon-name "accessories-text-editor")))
 821                         (dialog-run d)
 822                         (object-destroy d)))
 823                (quit (&rest args) (declare (ignore args)) (object-destroy window))
 824                (cb-eval (&rest args) (declare (ignore args))
 825                         (let ((buffer (text-view-buffer text-view)))
 826                           (multiple-value-bind (i1 i2) (text-buffer-get-selection-bounds buffer)
 827                             (when (and i1 i2)
 828                               (with-gtk-message-error-handler
 829                                 (let* ((text (text-buffer-slice buffer i1 i2))
 830                                        (value (eval (read-from-string text)))
 831                                        (value-str (format nil "~A" value))
 832                                        (pos (max (text-iter-offset i1) (text-iter-offset i2))))
 833                                   (text-buffer-insert buffer " => " :position (text-buffer-get-iter-at-offset buffer pos))
 834                                   (incf pos (length " => "))
 835                                   (text-buffer-insert buffer value-str :position (text-buffer-get-iter-at-offset buffer pos)))))))))
 836         (builder-connect-signals-simple builder `(("new" ,#'new)
 837                                                   ("open" ,#'cb-open)
 838                                                   ("save" ,#'save)
 839                                                   ("save-as" ,#'save-as)
 840                                                   ("cut" ,#'cut)
 841                                                   ("copy" ,#'copy)
 842                                                   ("paste" ,#'paste)
 843                                                   ("delete" ,#'cb-delete)
 844                                                   ("about" ,#'about)
 845                                                   ("quit" ,#'quit)
 846                                                   ("eval" ,#'cb-eval)))
 847         (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
 848         (connect-signal (text-view-buffer text-view) "changed" (lambda (b) (declare (ignore b)) (setf modified-p t) (set-properties)))
 849         (widget-show window)))))
 850
 851 (defun demo-class-browser ()
 852   "Show slots of a given class"
 853   (let ((output *standard-output*))
 854     (with-main-loop
 855       (let* ((window (make-instance 'gtk-window
 856                                     :window-position :center
 857                                     :title "Class Browser"
 858                                     :default-width 400
 859                                     :default-height 600))
 860              (search-entry (make-instance 'entry))
 861              (search-button (make-instance 'button :label "Search"))
 862              (scroll (make-instance 'scrolled-window
 863                                     :hscrollbar-policy :automatic
 864                                     :vscrollbar-policy :automatic))
 865              (slots-model (make-instance 'array-list-store))
 866              (slots-list (make-instance 'tree-view :model slots-model)))
 867         (let ((v-box (make-instance 'v-box))
 868               (search-box (make-instance 'h-box)))
 869           (container-add window v-box)
 870           (box-pack-start v-box search-box :expand nil)
 871           (box-pack-start search-box search-entry)
 872           (box-pack-start search-box search-button :expand nil)
 873           (box-pack-start v-box scroll)
 874           (container-add scroll slots-list))
 875         (store-add-column slots-model "gchararray"
 876                           (lambda (slot)
 877                             (format nil "~S" (closer-mop:slot-definition-name slot))))
 878         (let ((col (make-instance 'tree-view-column :title "Slot name"))
 879               (cr (make-instance 'cell-renderer-text)))
 880           (tree-view-column-pack-start col cr)
 881           (tree-view-column-add-attribute col cr "text" 0)
 882           (tree-view-append-column slots-list col))
 883         (labels ((display-class-slots (class)
 884                    (format output "Displaying ~A~%" class)
 885                    (loop
 886                       repeat (store-items-count slots-model)
 887                       do (store-remove-item slots-model (store-item slots-model 0)))
 888                    (closer-mop:finalize-inheritance class)
 889                    (loop
 890                       for slot in (closer-mop:class-slots class)
 891                       do (store-add-item slots-model slot)))
 892                  (on-search-clicked (button)
 893                    (declare (ignore button))
 894                    (with-gtk-message-error-handler
 895                      (let* ((class-name (read-from-string (entry-text search-entry)))
 896                             (class (find-class class-name)))
 897                        (display-class-slots class)))))
 898           (connect-signal search-button "clicked" #'on-search-clicked))
 899         (widget-show window)))))
 900
 901 (defun make-tree-from-sexp (l)
 902   (setf l (if (listp l) l (list l)))
 903   (let ((node (make-tree-node :item (make-tvi :title (format nil "~S" (first l))
 904                                               :value (format nil "~S" (class-of (first l)))))))
 905     (iter (for child in (rest l))
 906           (tree-node-insert-at node (make-tree-from-sexp child) (length (tree-node-children node))))
 907     node))
 908
 909 (defun demo-treeview-tree ()
 910   "Advanced demo: show s-expression tree structure"
 911   (within-main-loop
 912     (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (tree)"))
 913            (model (make-instance 'tree-lisp-store))
 914            (scroll (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
 915            (tree-view (make-instance 'tree-view :headers-visible t :width-request 300 :height-request 400 :rules-hint t))
 916            (h-box (make-instance 'h-box))
 917            (v-box (make-instance 'v-box))
 918            (entry (make-instance 'entry))
 919            (button (make-instance 'button :label "Display")))
 920       (tree-lisp-store-add-column model "gchararray" #'tvi-title)
 921       (tree-lisp-store-add-column model "gchararray" #'tvi-value)
 922       (tree-node-insert-at (tree-lisp-store-root model)
 923                            (make-tree-from-sexp '(lambda (object &rest initargs &key &allow-other-keys)
 924                                                   (* 1 2)
 925                                                   (- 3 4)))
 926                            0)
 927       (setf (tree-view-model tree-view) model
 928             (tree-view-tooltip-column tree-view) 0)
 929       (connect-signal tree-view "row-activated" (lambda (tv path column)
 930                                                   (declare (ignore tv column))
 931                                                   (format t "You clicked on row ~A~%" (tree-path-indices path))))
 932       (connect-signal button "clicked" (lambda (b)
 933                                          (declare (ignore b))
 934                                          (let ((object (read-from-string (entry-text entry))))
 935                                            (tree-node-remove-at (tree-lisp-store-root model) 0)
 936                                            (tree-node-insert-at (tree-lisp-store-root model)
 937                                                                 (make-tree-from-sexp object)
 938                                                                 0))))
 939       (container-add window v-box)
 940       (box-pack-start v-box h-box :expand nil)
 941       (box-pack-start h-box entry)
 942       (box-pack-start h-box button :expand nil)
 943       (box-pack-start v-box scroll)
 944       (container-add scroll tree-view)
 945       (let ((column (make-instance 'tree-view-column :title "Value" :sort-column-id 0))
 946             (renderer (make-instance 'cell-renderer-text :text "A text")))
 947         (tree-view-column-pack-start column renderer)
 948         (tree-view-column-add-attribute column renderer "text" 0)
 949         (tree-view-append-column tree-view column)
 950         (print (tree-view-column-tree-view column))
 951         (print (tree-view-column-cell-renderers column)))
 952       (let ((column (make-instance 'tree-view-column :title "Type"))
 953             (renderer (make-instance 'cell-renderer-text :text "A text")))
 954         (tree-view-column-pack-start column renderer)
 955         (tree-view-column-add-attribute column renderer "text" 1)
 956         (tree-view-append-column tree-view column)
 957         (print (tree-view-column-tree-view column))
 958         (print (tree-view-column-cell-renderers column)))
 959       (widget-show window))))
 960
 961 (defclass custom-window (gtk-window)
 962   ((label :initform (make-instance 'label :label "A label text") :reader custom-window-label)
 963    (button :initform (make-instance 'button :label "Click me!") :reader custom-window-button))
 964   (:metaclass gobject-class)
 965   (:default-initargs :title "Custom window with default initargs" :default-width 320 :default-height 240))
 966
 967 (defun custom-window-label-text (w)
 968   (label-label (custom-window-label w)))
 969
 970 (defun (setf custom-window-label-text) (new-value w)
 971   (setf (label-label (custom-window-label w)) new-value))
 972
 973 (defmethod initialize-instance :after ((w custom-window) &key &allow-other-keys)
 974   (let ((box (make-instance 'v-box)))
 975     (box-pack-start box (custom-window-label w))
 976     (box-pack-start box (custom-window-button w) :expand nil)
 977     (container-add w box))
 978   (connect-signal (custom-window-button w) "clicked" (lambda (b)
 979                                                        (declare (ignore b))
 980                                                        (custom-window-button-clicked w))))
 981
 982 (defun custom-window-button-clicked (w)
 983   (setf (custom-window-label-text w)
 984         (format nil "Now is: ~A~%" (get-internal-run-time))))
 985
 986 (defun test-custom-window ()
 987   "Simple test of non-GObject subclass of GtkWindow"
 988   (within-main-loop
 989     (let ((w (make-instance 'custom-window)))
 990       (widget-show w))))
 991
 992 (defun test-assistant ()
 993   "Simple test of GtkAssistant wizard"
 994   (let ((output *standard-output*))
 995     (within-main-loop
 996       (let ((d (make-instance 'assistant :title "Username wizard"))
 997             (p-1 (make-instance 'h-box))
 998             (entry (make-instance 'entry))
 999             (p-2 (make-instance 'label :label "Click Apply to close this wizard")))
1000         (box-pack-start p-1 (make-instance 'label :label "Enter your name:") :expand nil)
1001         (box-pack-start p-1 entry)
1002         (assistant-append-page d p-1)
1003         (assistant-append-page d p-2)
1004         (setf (assistant-child-title d p-1) "Username wizard"
1005               (assistant-child-title d p-2) "Username wizard"
1006               (assistant-child-complete d p-1) nil
1007               (assistant-child-complete d p-2) t
1008               (assistant-child-page-type d p-1) :intro
1009               (assistant-child-page-type d p-2) :confirm
1010               (assistant-forward-page-function d) (lambda (i)
1011                                                     (format output "(assistant-forward-page-function ~A)~%" i)
1012                                                     (ecase i
1013                                                       (0 1)
1014                                                       (1 -1))))
1015         (connect-signal entry "notify::text" (lambda (object pspec)
1016                                                (declare (ignore object pspec))
1017                                                (setf (assistant-child-complete d p-1)
1018                                                      (plusp (length (entry-text entry))))))
1019         (let ((w (make-instance 'label :label "A label in action area")))
1020           (widget-show w)
1021           (assistant-add-action-widget d w))
1022         (connect-signal d "cancel" (lambda (assistant)
1023                                      (declare (ignore assistant))
1024                                      (object-destroy d)
1025                                      (format output "Canceled~%")))
1026         (connect-signal d "close" (lambda (assistant)
1027                                     (declare (ignore assistant))
1028                                     (object-destroy d)
1029                                     (format output "Thank you, ~A~%" (entry-text entry))))
1030         (connect-signal d "prepare" (lambda (assistant page-widget)
1031                                       (declare (ignore assistant page-widget))
1032                                       (format output "Assistant ~A has ~A pages and is on ~Ath page~%"
1033                                               d (assistant-n-pages d) (assistant-current-page d))))
1034         (widget-show d)))))
1035
1036 (defun test-entry-completion ()
1037   "Not working example of GtkEntryCompletion"
1038   (within-main-loop
1039     (let* ((w (make-instance 'gtk-window))
1040            (model (make-instance 'tree-lisp-store)))
1041       (tree-lisp-store-add-column model "gchararray" #'identity)
1042       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Monday") 0)
1043       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Tuesday") 0)
1044       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Wednesday") 0)
1045       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Thursday") 0)
1046       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Friday") 0)
1047       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Saturday") 0)
1048       (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Sunday") 0)
1049       (let* ((completion (make-instance 'entry-completion :model model :text-column 0))
1050              (e (make-instance 'entry :completion completion)))
1051         (setf (entry-completion-text-column completion) 0)
1052         (container-add w e))
1053       (widget-show w))))
1054
1055 (defun test-ui-markup ()
1056   (within-main-loop
1057     (let ((label (make-instance 'label :label "Hello!")))
1058       (let-ui (gtk-window :type :toplevel
1059                           :position :center
1060                           :title "Hello, world!"
1061                           :default-width 300
1062                           :default-height 400
1063                           :var w
1064                           (v-box
1065                            (:expr label) :expand nil
1066                            (scrolled-window
1067                             :hscrollbar-policy :automatic
1068                             :vscrollbar-policy :automatic
1069                             :shadow-type :etched-in
1070                             (text-view :var tv))
1071                            (h-box
1072                             (label :label "Insert:") :expand nil
1073                             (entry :var entry)
1074                             (button :label "gtk-ok" :use-stock t :var btn) :expand nil)
1075                            :expand nil
1076                            (label :label "Table packing")
1077                            :expand nil
1078                            (table
1079                             :n-columns 2
1080                             :n-rows 2
1081                             (label :label "2 x 1") :left 0 :right 2 :top 0 :bottom 1
1082                             (label :label "1 x 1") :left 0 :right 1 :top 1 :bottom 2
1083                             (label :label "1 x 1") :left 1 :right 2 :top 1 :bottom 2)))
1084         (connect-signal btn "clicked"
1085                         (lambda (b)
1086                           (declare (ignore b))
1087                           (text-buffer-insert (text-view-buffer tv)
1088                                               (entry-text entry))))
1089         (widget-show w)))))
1090
1091 (defun test-list-store ()
1092   "Demonstrates usage of list store"
1093   (within-main-loop
1094     (let-ui (gtk-window
1095              :type :toplevel
1096              :title "GtkListStore"
1097              :default-width 600
1098              :default-height 400
1099              :var w
1100              (v-box
1101               (label :label "A GtkListStore") :expand nil
1102               (scrolled-window
1103                :hscrollbar-policy :automatic
1104                :vscrollbar-policy :automatic
1105                (tree-view :var tv))))
1106       (let ((l (make-instance 'list-store :column-types '("gint" "gchararray"))))
1107         (iter (for i from 0 below 100)
1108               (for n = (random 10000000))
1109               (for s = (format nil "~R" n))
1110               (list-store-insert-with-values l i n s))
1111         (setf (tree-view-model tv) l)
1112         (let ((column (make-instance 'tree-view-column :title "Number" :sort-column-id 0))
1113               (renderer (make-instance 'cell-renderer-text :text "A text")))
1114           (tree-view-column-pack-start column renderer)
1115           (tree-view-column-add-attribute column renderer "text" 0)
1116           (tree-view-append-column tv column))
1117         (let ((column (make-instance 'tree-view-column :title "As string" :sort-column-id 1))
1118               (renderer (make-instance 'cell-renderer-text :text "A text")))
1119           (tree-view-column-pack-start column renderer)
1120           (tree-view-column-add-attribute column renderer "text" 1)
1121           (tree-view-append-column tv column))
1122         (connect-signal tv "row-activated"
1123                         (lambda (w path column)
1124                           (declare (ignore w column))
1125                           (let* ((iter (tree-model-iter-by-path l path))
1126                                  (n (tree-model-value l iter 0))
1127                                  (dialog (make-instance 'message-dialog
1128                                                         :title "Clicked"
1129                                                         :text (format nil "Number ~A was clicked" n)
1130                                                         :buttons :ok)))
1131                             (dialog-run dialog)
1132                             (object-destroy dialog)))))
1133       (widget-show w))))
1134
1135 (defun test-tree-store ()
1136   "Demonstrates usage of tree store"
1137   (within-main-loop
1138     (let-ui (gtk-window
1139              :type :toplevel
1140              :title "GtkListStore"
1141              :default-width 600
1142              :default-height 400
1143              :var w
1144              (v-box
1145               (label :label "A GtkListStore") :expand nil
1146               (scrolled-window
1147                :hscrollbar-policy :automatic
1148                :vscrollbar-policy :automatic
1149                (tree-view :var tv))))
1150       (let ((l (make-instance 'tree-store :column-types '("gint" "gchararray"))))
1151         (iter (for i from 0 below 100)
1152               (for n = (random 10000000))
1153               (for s = (format nil "~R" n))
1154               (for it = (tree-store-insert-with-values l nil i n s))
1155               (iter (for j from 0 below 10)
1156                     (for n2 = (random 10000000))
1157                     (for s2 = (format nil "~R" n2))
1158                     (tree-store-insert-with-values l it j n2 s2)))
1159         (setf (tree-view-model tv) l)
1160         (let ((column (make-instance 'tree-view-column :title "Number" :sort-column-id 0))
1161               (renderer (make-instance 'cell-renderer-text :text "A text")))
1162           (tree-view-column-pack-start column renderer)
1163           (tree-view-column-add-attribute column renderer "text" 0)
1164           (tree-view-append-column tv column))
1165         (let ((column (make-instance 'tree-view-column :title "As string" :sort-column-id 1))
1166               (renderer (make-instance 'cell-renderer-text :text "A text")))
1167           (tree-view-column-pack-start column renderer)
1168           (tree-view-column-add-attribute column renderer "text" 1)
1169           (tree-view-append-column tv column))
1170         (connect-signal tv "row-activated"
1171                         (lambda (w path column)
1172                           (declare (ignore w column))
1173                           (let* ((iter (tree-model-iter-by-path l path))
1174                                  (n (tree-model-value l iter 0))
1175                                  (dialog (make-instance 'message-dialog
1176                                                         :title "Clicked"
1177                                                         :text (format nil "Number ~A was clicked" n)
1178                                                         :buttons :ok)))
1179                             (dialog-run dialog)
1180                             (object-destroy dialog)))))
1181       (widget-show w))))
1182
1183 (defun test-gdk-expose (gdk-window)
1184   (let* ((gc (graphics-context-new gdk-window)))
1185     (multiple-value-bind (w h) (drawable-get-size gdk-window)
1186       (setf (graphics-context-rgb-bg-color gc) (make-color :red 0 :green 0 :blue 0))
1187       (draw-polygon gdk-window gc t (list (make-point :x 0 :y 0)
1188                                           (make-point :x (truncate w 2) :y 0)
1189                                           (make-point :x w :y (truncate h 2))
1190                                           (make-point :x w :y h)
1191                                           (make-point :x (truncate w 2) :y h)
1192                                           (make-point :x 0 :y (truncate h 2))))
1193       (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 0 :blue 0))
1194       (draw-point gdk-window gc 20 10)
1195       (setf (graphics-context-rgb-fg-color gc) (make-color :red 0 :green 65535 :blue 0))
1196       (draw-points gdk-window gc (list (make-point :x 15 :y 20) (make-point :x 35 :y 40)))
1197       (setf (graphics-context-rgb-fg-color gc) (make-color :red 0 :green 0 :blue 65535))
1198       (draw-line gdk-window gc 60 30 40 50)
1199       (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 65535 :blue 0))
1200       (draw-lines gdk-window gc (list (make-point :x 10 :y 30) (make-point :x 15 :y 40)
1201                                       (make-point :x 15 :y 50) (make-point :x 10 :y 56)))
1202       (setf (graphics-context-rgb-fg-color gc) (make-color :red 0 :green 65535 :blue 65535))
1203       (draw-segments gdk-window gc (list (make-segment :x1 35 :y1 35 :x2 55 :y2 35)
1204                                          (make-segment :x1 65 :y1 35 :x2 43 :y2 17)))
1205       (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 0 :blue 65535)
1206             (graphics-context-rgb-bg-color gc) (make-color :red 32767 :green 0 :blue 32767))
1207       (draw-arc gdk-window gc nil 70 30 75 50 (* 64 75) (* 64 200))
1208       (draw-polygon gdk-window gc nil (list (make-point :x 20 :y 40)
1209                                             (make-point :x 30 :y 50)
1210                                             (make-point :x 40 :y 70)
1211                                             (make-point :x 30 :y 80)
1212                                             (make-point :x 10 :y 55)))
1213       (setf (graphics-context-rgb-fg-color gc) (make-color :red 16384 :green 16384 :blue 65535))
1214       (draw-trapezoids gdk-window gc (list (make-trapezoid :y1 50.0d0 :y2 70.0d0
1215                                                            :x11 30.0d0 :x12 45.0d0
1216                                                            :x21 70.0d0 :x22 50.0d0))))))
1217
1218 (defun test-gdk ()
1219   "Test various gdk primitives"
1220   (within-main-loop
1221     (let ((window (make-instance 'gtk-window :type :toplevel :app-paintable t)))
1222       (connect-signal window "destroy" (lambda (widget)
1223                                          (declare (ignore widget))
1224                                          (leave-gtk-main)))
1225       (connect-signal window "destroy" (lambda (widget)
1226                                          (declare (ignore widget))
1227                                          (leave-gtk-main)))
1228       (connect-signal window "expose-event"
1229                       (lambda (widget event)
1230                         (declare (ignore widget event))
1231                         (test-gdk-expose (widget-window window))))
1232       (connect-signal window "configure-event"
1233                       (lambda (widget event)
1234                         (declare (ignore widget event))
1235                         (widget-queue-draw window)))
1236       (widget-show window)
1237       (push :pointer-motion-mask (gdk-window-events (widget-window window))))))