chiark - git - mdw - clg/blob - examples/testgtk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: testgtk.lisp,v 1.27 2005/04/18 10:39:32 espen Exp $
  19
  20 (defpackage "TESTGTK"
  21   (:use "COMMON-LISP" "GTK"))
  22
  23 (in-package "TESTGTK")
  24
  25 (defmacro define-toplevel (name (window title &rest initargs) &body body)
  26   `(let ((,window nil))
  27      (defun ,name ()
  28        (unless ,window
  29          (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
  30          (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
  31          ,@body)
  32
  33        (when ,window
  34          (if (not (widget-visible-p ,window))
  35              (widget-show ,window)
  36            (widget-hide ,window))))))
  37
  38
  39 (defmacro define-dialog (name (dialog title &optional (class 'dialog)
  40                                &rest initargs)
  41                          &body body)
  42   `(let ((,dialog nil))
  43      (defun ,name ()
  44        (unless ,dialog
  45          (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
  46          (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
  47          ,@body)
  48
  49        (when ,dialog
  50          (if (not (widget-visible-p ,dialog))
  51              (widget-show ,dialog)
  52            (widget-hide ,dialog))))))
  53
  54
  55 (defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
  56   `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
  57     ,@body
  58     (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
  59
  60
  61
  62 ;;; Pixmaps used in some of the tests
  63
  64 (defvar gtk-mini-xpm
  65   #("15 20 17 1"
  66     "       c None"
  67     ".      c #14121F"
  68     "+      c #278828"
  69     "@      c #9B3334"
  70     "#      c #284C72"
  71     "$      c #24692A"
  72     "%      c #69282E"
  73     "&      c #37C539"
  74     "*      c #1D2F4D"
  75     "=      c #6D7076"
  76     "-      c #7D8482"
  77     ";      c #E24A49"
  78     ">      c #515357"
  79     ",      c #9B9C9B"
  80     "'      c #2FA232"
  81     ")      c #3CE23D"
  82     "!      c #3B6CCB"
  83     "               "
  84     "      ***>     "
  85     "    >.*!!!*    "
  86     "   ***....#*=  "
  87     "  *!*.!!!**!!# "
  88     " .!!#*!#*!!!!# "
  89     " @%#!.##.*!!$& "
  90     " @;%*!*.#!#')) "
  91     " @;;@%!!*$&)'' "
  92     " @%.%@%$'&)$+' "
  93     " @;...@$'*'*)+ "
  94     " @;%..@$+*.')$ "
  95     " @;%%;;$+..$)# "
  96     " @;%%;@$$$'.$# "
  97     " %;@@;;$$+))&* "
  98     "  %;;;@+$&)&*  "
  99     "   %;;@'))+>   "
 100     "    %;@'&#     "
 101     "     >%$$      "
 102     "      >=       "))
 103
 104 (defvar book-closed-xpm
 105   #("16 16 6 1"
 106     "       c None s None"
 107     ".      c black"
 108     "X      c red"
 109     "o      c yellow"
 110     "O      c #808080"
 111     "#      c white"
 112     "                "
 113     "       ..       "
 114     "     ..XX.      "
 115     "   ..XXXXX.     "
 116     " ..XXXXXXXX.    "
 117     ".ooXXXXXXXXX.   "
 118     "..ooXXXXXXXXX.  "
 119     ".X.ooXXXXXXXXX. "
 120     ".XX.ooXXXXXX..  "
 121     " .XX.ooXXX..#O  "
 122     "  .XX.oo..##OO. "
 123     "   .XX..##OO..  "
 124     "    .X.#OO..    "
 125     "     ..O..      "
 126     "      ..        "
 127     "                "))
 128
 129 (defvar mini-page-xpm
 130   #("16 16 4 1"
 131     "       c None s None"
 132     ".      c black"
 133     "X      c white"
 134     "o      c #808080"
 135     "                "
 136     "   .......      "
 137     "   .XXXXX..     "
 138     "   .XoooX.X.    "
 139     "   .XXXXX....   "
 140     "   .XooooXoo.o  "
 141     "   .XXXXXXXX.o  "
 142     "   .XooooooX.o  "
 143     "   .XXXXXXXX.o  "
 144     "   .XooooooX.o  "
 145     "   .XXXXXXXX.o  "
 146     "   .XooooooX.o  "
 147     "   .XXXXXXXX.o  "
 148     "   ..........o  "
 149     "    oooooooooo  "
 150     "                "))
 151
 152 (defvar book-open-xpm
 153   #("16 16 4 1"
 154     "       c None s None"
 155     ".      c black"
 156     "X      c #808080"
 157     "o      c white"
 158     "                "
 159     "  ..            "
 160     " .Xo.    ...    "
 161     " .Xoo. ..oo.    "
 162     " .Xooo.Xooo...  "
 163     " .Xooo.oooo.X.  "
 164     " .Xooo.Xooo.X.  "
 165     " .Xooo.oooo.X.  "
 166     " .Xooo.Xooo.X.  "
 167     " .Xooo.oooo.X.  "
 168     "  .Xoo.Xoo..X.  "
 169     "   .Xo.o..ooX.  "
 170     "    .X..XXXXX.  "
 171     "    ..X.......  "
 172     "     ..         "
 173     "                "))
 174
 175
 176
 177 ;;; Button box
 178
 179 (defun create-bbox-in-frame (class frame-label spacing width height layout)
 180   (declare (ignore width height))
 181   (make-instance 'frame
 182    :label frame-label
 183    :child (make-instance class
 184            :border-width 5 :layout-style layout :spacing spacing
 185            :child (make-instance 'button :stock "gtk-ok")
 186            :child (make-instance 'button :stock "gtk-cancel")
 187            :child (make-instance 'button :stock "gtk-help"))))
 188
 189 (define-toplevel create-button-box (window "Button Boxes")
 190   (make-instance 'v-box
 191    :parent window :border-width 10 :spacing 10
 192    :child (make-instance 'frame
 193            :label "Horizontal Button Boxes"
 194            :child (make-instance 'v-box
 195                    :border-width 10 :spacing 10
 196                    :children (mapcar
 197                               #'(lambda (args)
 198                                   (apply #'create-bbox-in-frame
 199                                    'h-button-box args))
 200                               '(("Spread" 40 85 20 :spread)
 201                                 ("Edge" 40 85 20 :edge)
 202                                 ("Start" 40 85 20 :start)
 203                                 ("End" 40 85 20 :end)))))
 204    :child (make-instance 'frame
 205            :label "Vertical Button Boxes"
 206            :child (make-instance 'h-box
 207                    :border-width 10 :spacing 10
 208                    :children (mapcar
 209                               #'(lambda (args)
 210                                   (apply #'create-bbox-in-frame
 211                                    'v-button-box args))
 212                               '(("Spread" 30 85 20 :spread)
 213                                 ("Edge" 30 85 20 :edge)
 214                                 ("Start" 30 85 20 :start)
 215                                 ("End" 30 85 20 :end)))))))
 216
 217
 218 ;; Buttons
 219
 220 (define-simple-dialog create-buttons (dialog "Buttons")
 221   (let ((table (make-instance 'table
 222                 :n-rows 3 :n-columns 3 :homogeneous nil
 223                 :row-spacing 5 :column-spacing 5 :border-width 10
 224                 :parent dialog))
 225           (buttons (loop
 226                     for n from 1 to 10
 227                     collect (make-instance 'button
 228                              :label (format nil "button~D" (1+ n))))))
 229
 230     (dotimes (column 3)
 231       (dotimes (row 3)
 232         (let ((button (nth (+ (* 3 row) column) buttons))
 233               (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
 234           (signal-connect button 'clicked
 235                           #'(lambda ()
 236                               (if (widget-visible-p button+1)
 237                                   (widget-hide button+1)
 238                                 (widget-show button+1))))
 239           (table-attach table button column (1+ column) row (1+ row)
 240                         :options '(:expand :fill)))))))
 241
 242
 243 ;; Calenadar
 244
 245 (define-simple-dialog create-calendar (dialog "Calendar")
 246   (make-instance 'v-box
 247    :parent dialog :border-width 10
 248    :child (make-instance 'calendar)))
 249
 250
 251 ;;; Check buttons
 252
 253 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
 254   (make-instance 'v-box
 255    :border-width 10 :spacing 10 :parent dialog
 256    :children (loop
 257               for n from 1 to 3
 258               collect (make-instance 'check-button
 259                        :label (format nil "Button~D" n)))))
 260
 261
 262
 263 ;;; Color selection
 264
 265 (define-dialog create-color-selection (dialog "Color selection dialog"
 266                                        'color-selection-dialog
 267                                        :allow-grow nil :allow-shrink nil
 268                                        :show-children nil)
 269   (with-slots (colorsel) dialog
 270     (let ((button (make-instance 'check-button :label "Show Opacity")))
 271       (dialog-add-action-widget dialog button
 272        #'(lambda ()
 273           (setf
 274            (color-selection-has-opacity-control-p colorsel)
 275            (toggle-button-active-p button)))))
 276
 277     (let ((button (make-instance 'check-button :label "Show Palette")))
 278       (dialog-add-action-widget dialog button
 279        #'(lambda ()
 280           (setf
 281            (color-selection-has-palette-p colorsel)
 282            (toggle-button-active-p button)))))
 283
 284     (signal-connect dialog :ok
 285      #'(lambda ()
 286          (let ((color (color-selection-current-color colorsel)))
 287            (format t "Selected color: ~A~%" color)
 288            (setf (color-selection-current-color colorsel) color)
 289            (widget-hide dialog))))
 290
 291     (signal-connect dialog :cancel #'widget-destroy :object t)))
 292
 293
 294 ;;; Cursors
 295
 296 (defun clamp (n min-val max-val)
 297   (declare (number n min-val max-val))
 298   (max (min n max-val) min-val))
 299
 300 (defun set-cursor (spinner drawing-area label)
 301   (let ((cursor
 302          (glib:int-enum
 303           (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
 304           'gdk:cursor-type)))
 305     (setf (label-label label) (string-downcase cursor))
 306     (setf (widget-cursor drawing-area) cursor)))
 307
 308 (defun cursor-expose (drawing-area event)
 309   (declare (ignore event))
 310   (multiple-value-bind (width height)
 311       (widget-get-size-allocation drawing-area)
 312     (let* ((window (widget-window drawing-area))
 313            (style (widget-style drawing-area))
 314            (white-gc (style-white-gc style))
 315            (gray-gc (style-bg-gc style :normal))
 316            (black-gc (style-black-gc style)))
 317       (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
 318       (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
 319                           (floor height 2))
 320       (gdk:draw-rectangle window gray-gc t (floor width 3)
 321                           (floor height 3) (floor width 3)
 322                           (floor height 3))))
 323   t)
 324
 325 (define-simple-dialog create-cursors (dialog "Cursors")
 326   (let ((spinner (make-instance 'spin-button
 327                   :adjustment (adjustment-new
 328                                0 0
 329                                (1- (glib:enum-int :last-cursor 'gdk:cursor-type))
 330                                2 10 0)))
 331         (drawing-area (make-instance 'drawing-area
 332                        :width-request 80 :height-request 80
 333                        :events '(:exposure :button-press)))
 334         (label (make-instance 'label :label "XXX")))
 335
 336     (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
 337
 338     (signal-connect drawing-area 'button-press-event
 339      #'(lambda (event)
 340          (case (gdk:event-button event)
 341            (1 (spin-button-spin spinner :step-forward))
 342            (3 (spin-button-spin spinner :step-backward)))
 343          t))
 344
 345     (signal-connect drawing-area 'scroll-event
 346      #'(lambda (event)
 347          (case (gdk:event-direction event)
 348            (:up (spin-button-spin spinner :step-forward))
 349            (:down (spin-button-spin spinner :step-backward)))
 350          t))
 351
 352     (signal-connect spinner 'changed
 353      #'(lambda ()
 354          (set-cursor spinner drawing-area label)))
 355
 356     (make-instance 'v-box
 357      :parent dialog :border-width 10 :spacing 5
 358      :child (list
 359              (make-instance 'h-box
 360               :border-width 5
 361               :child (list
 362                       (make-instance 'label :label "Cursor Value : ")
 363                       :expand nil)
 364               :child spinner)
 365              :expand nil)
 366      :child (make-instance 'frame
 367              :label "Cursor Area" :label-xalign 0.5 :border-width 10
 368              :child drawing-area)
 369      :child (list label :expand nil))
 370
 371     (widget-realize drawing-area)
 372     (set-cursor spinner drawing-area label)))
 373
 374
 375 ;;; Dialog
 376
 377 (let ((dialog nil))
 378   (defun create-dialog ()
 379     (unless dialog
 380       (setq dialog (make-instance 'dialog
 381                     :title "Dialog" :default-width 200
 382                     :button "Toggle"
 383                     :button (list "gtk-ok" #'widget-destroy :object t)
 384                     :signal (list 'destroy
 385                              #'(lambda ()
 386                                  (setq dialog nil)))))
 387
 388       (let ((label (make-instance 'label
 389                     :label "Dialog Test" :xpad 10 :ypad 10 :visible t
 390                     :parent dialog)))
 391         (signal-connect dialog "Toggle"
 392          #'(lambda ()
 393              (if (widget-visible-p label)
 394                  (widget-hide label)
 395                (widget-show label))))))
 396
 397     (if (widget-visible-p dialog)
 398         (widget-hide dialog)
 399        (widget-show dialog))))
 400
 401
 402 ;; Entry
 403
 404 (define-simple-dialog create-entry (dialog "Entry")
 405   (let ((main (make-instance 'v-box
 406                :border-width 10 :spacing 10 :parent dialog)))
 407
 408     (let ((entry (make-instance 'entry :text "hello world" :parent main)))
 409       (editable-select-region entry 0 5) ; this has no effect when
 410                                          ; entry is editable
 411 ;;     (editable-insert-text entry "great " 6)
 412 ;;     (editable-delete-text entry 6 12)
 413
 414       (let ((combo (make-instance 'combo-box-entry
 415                     :parent main
 416                     :content '("item0"
 417                                "item1 item1"
 418                                "item2 item2 item2"
 419                                "item3 item3 item3 item3"
 420                                "item4 item4 item4 item4 item4"
 421                                "item5 item5 item5 item5 item5 item5"
 422                                "item6 item6 item6 item6 item6"
 423                                "item7 item7 item7 item7"
 424                                "item8 item8 item8"
 425                                "item9 item9"))))
 426         (with-slots (child) combo
 427           (setf (editable-text child) "hello world")
 428           (editable-select-region child 0)))
 429
 430       (flet ((create-check-button (label slot)
 431                (make-instance 'check-button
 432                 :label label :active t :parent main
 433                 :signal (list 'toggled
 434                               #'(lambda (button)
 435                                   (setf (slot-value entry slot)
 436                                         (toggle-button-active-p button)))
 437                               :object t))))
 438
 439         (create-check-button "Editable" 'editable)
 440         (create-check-button "Visible" 'visibility)
 441         (create-check-button "Sensitive" 'sensitive)))))
 442
 443
 444 ;; Expander
 445
 446 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
 447   (make-instance 'v-box
 448    :parent dialog :spacing 5 :border-width 5
 449    :child (create-label "Expander demo. Click on the triangle for details.")
 450    :child (make-instance 'expander
 451            :label "Details"
 452            :child (create-label "Details can be shown or hidden."))))
 453
 454
 455 ;; File chooser dialog
 456
 457 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
 458   (file-chooser-add-filter dialog
 459    (make-instance 'file-filter :name "All files" :pattern "*"))
 460   (file-chooser-add-filter dialog
 461    (make-instance 'file-filter :name "Common Lisp source code"
 462     :patterns '("*.lisp" "*.lsp")))
 463
 464   (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
 465   (dialog-add-button dialog "gtk-ok"
 466    #'(lambda ()
 467        (if (slot-boundp dialog 'filename)
 468            (format t "Selected file: ~A~%" (file-chooser-filename dialog))
 469          (write-line "No files selected"))
 470        (widget-destroy dialog))))
 471
 472
 473 ;; Font selection dialog
 474
 475 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
 476   (make-instance 'h-box
 477    :parent window :spacing 8 :border-width 8
 478    :child (make-instance 'label :label "Pick a font")
 479    :child (make-instance 'font-button
 480            :use-font t :title "Font Selection Dialog")))
 481
 482
 483 ;;; Icon View
 484
 485 #+gtk2.6
 486 (let ((file-pixbuf nil)
 487       (folder-pixbuf nil))
 488   (defun load-pixbufs ()
 489     (unless file-pixbuf
 490       (handler-case
 491           (setf
 492            file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
 493            folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
 494         (glib:glib-error (condition)
 495           (make-instance 'message-dialog
 496            :message-type :error :visible t
 497            :text "<b>Failed to load an image</b>"
 498            :secondary-text (glib:gerror-message condition)
 499            :signal (list :close #'widget-destroy :object t))
 500           (return-from load-pixbufs nil))))
 501     t)
 502
 503   (defun fill-store (store directory)
 504     (list-store-clear store)
 505     (let ((dir #+cmu(unix:open-dir directory)
 506                #+sbcl(sb-posix:opendir directory)))
 507       (unwind-protect
 508           (loop
 509            as filename = #+cmu(unix:read-dir dir)
 510                          #+sbcl(let ((dirent (sb-posix:readdir dir)))
 511                                  (unless (sb-grovel::foreign-nullp dirent)
 512                                    (sb-posix:dirent-name dirent)))
 513            while filename
 514            unless (or (equal filename ".") (equal filename ".."))
 515            do (let* ((pathname (format nil "~A~A" directory filename))
 516                      (directory-p
 517                       #+cmu(eq (unix:unix-file-kind pathname) :directory)
 518                       #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
 519                 (list-store-append store
 520                  (vector
 521                   filename
 522                   (if directory-p folder-pixbuf file-pixbuf)
 523                   directory-p))))
 524         #+cmu(unix:close-dir dir)
 525         #+sbcl(sb-posix:closedir dir))))
 526
 527   (defun sort-func (store a b)
 528     (let ((a-dir-p (tree-model-value store a 'directory-p))
 529           (b-dir-p (tree-model-value store b 'directory-p))
 530           (a-name (tree-model-value store a 'filename))
 531           (b-name (tree-model-value store b 'filename)))
 532       (cond
 533        ((and a-dir-p (not b-dir-p)) :before)
 534        ((and (not a-dir-p) b-dir-p) :after)
 535        ((string< a-name b-name) :before)
 536        ((string> a-name b-name) :after)
 537        (t :equal))))
 538
 539   (defun parent-dir (dir)
 540     (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
 541       (subseq dir 0 end)))
 542
 543   (define-toplevel create-icon-view (window "Icon View demo"
 544                                      :default-width 650
 545                                      :default-height 400)
 546     (if (not (load-pixbufs))
 547         (widget-destroy window)
 548       (let* ((directory "/")
 549              (store (make-instance 'list-store
 550                      :column-types '(string gdk:pixbuf boolean)
 551                      :column-names '(filename pixbuf directory-p)))
 552              (icon-view (make-instance 'icon-view
 553                          :model store :selection-mode :multiple
 554                          :text-column 'filename :pixbuf-column 'pixbuf))
 555              (up (make-instance 'tool-button
 556                   :stock "gtk-go-up" :is-important t :sensitive nil))
 557              (home (make-instance 'tool-button
 558                     :stock  "gtk-home" :is-important t)))
 559         (tree-sortable-set-sort-func store :default #'sort-func)
 560         (tree-sortable-set-sort-column store :default :ascending)
 561         (fill-store store directory)
 562
 563         (signal-connect icon-view 'item-activated
 564          #'(lambda (path)
 565              (when (tree-model-value store path 'directory-p)
 566                (setq directory
 567                      (concatenate 'string directory (tree-model-value store path 'filename) "/"))
 568                (fill-store store directory)
 569                (setf (widget-sensitive-p up) t))))
 570
 571         (signal-connect up 'clicked
 572          #'(lambda ()
 573              (unless (string= directory "/")
 574                (setq directory (parent-dir directory))
 575                (fill-store store directory)
 576                (setf
 577                 (widget-sensitive-p home)
 578                 (not (string= directory (namestring (truename #p"clg:")))))
 579                (setf (widget-sensitive-p up) (not (string= directory "/"))))))
 580
 581         (signal-connect home 'clicked
 582          #'(lambda ()
 583              (setq directory (namestring (truename #p"clg:")))
 584              (fill-store store directory)
 585              (setf (widget-sensitive-p up) t)
 586              (setf (widget-sensitive-p home) nil)))
 587
 588         (make-instance 'v-box
 589          :parent window
 590          :child (list
 591                  (make-instance 'toolbar :child up :child home)
 592                  :fill nil :expand nil)
 593          :child (make-instance 'scrolled-window
 594                  :shadow-type :etched-in :policy :automatic
 595                  :child icon-view))))))
 596
 597
 598 ;;; Image
 599
 600 (define-toplevel create-image (window "Image" :resizable nil)
 601   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 602
 603
 604 ;;; Labels
 605
 606 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 607   (flet ((create-label-in-frame (frame-label label-text &rest args)
 608            (list
 609             (make-instance 'frame
 610              :label frame-label
 611              :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
 612             :fill nil :expand nil)))
 613     (make-instance 'h-box
 614      :spacing 5 :parent window
 615      :child-args '(:fill nil :expand nil)
 616      :child (make-instance 'v-box
 617              :spacing 5
 618              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 619              :child (create-label-in-frame "Multi-line Label"
 620 "This is a Multi-line label.
 621 Second line
 622 Third line")
 623              :child (create-label-in-frame "Left Justified Label"
 624 "This is a Left-Justified
 625 Multi-line.
 626 Third line"
 627                       :justify :left)
 628              :child (create-label-in-frame "Right Justified Label"
 629 "This is a Right-Justified
 630 Multi-line.
 631 Third line"
 632                      :justify :right))
 633      :child (make-instance 'v-box
 634              :spacing 5
 635              :child (create-label-in-frame "Line wrapped label"
 636 "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.
 637      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 638                       :wrap t)
 639
 640              :child (create-label-in-frame "Filled, wrapped label"
 641 "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.
 642     This is a new paragraph.
 643     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 644                       :justify :fill :wrap t)
 645
 646              :child (create-label-in-frame "Underlined label"
 647 (#+cmu glib:latin1-to-unicode #+sbcl identity
 648 "This label is underlined!
 649 This one is underlined (æøåÆØÅ) in quite a funky fashion")
 650                       :justify :left
 651                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 652
 653
 654 ;;; Layout
 655
 656 (defun layout-expose (layout event)
 657   (when (eq (gdk:event-window event) (layout-bin-window layout))
 658     (with-slots (gdk:x gdk:y gdk:width gdk:height) event
 659       (let ((imin (truncate gdk:x 10))
 660             (imax (truncate (+ gdk:x gdk:width 9) 10))
 661             (jmin (truncate gdk:y 10))
 662             (jmax (truncate (+ gdk:y gdk:height 9) 10)))
 663
 664         (let ((window (layout-bin-window layout))
 665               (gc (style-black-gc (widget-style layout))))
 666           (loop
 667            for i from imin below imax
 668            do (loop
 669                for j from jmin below jmax
 670                unless (zerop (mod (+ i j) 2))
 671                do (gdk:draw-rectangle
 672                    window gc t (* 10 i) (* 10 j)
 673                    (1+ (mod i 10)) (1+ (mod j 10)))))))))
 674   nil)
 675
 676 (define-toplevel create-layout (window "Layout" :default-width 200
 677                                                 :default-height 200)
 678   (let ((layout (make-instance 'layout
 679                  :parent (make-instance 'scrolled-window :parent window)
 680                  :width 1600 :height 128000 :events '(:exposure)
 681                  :signal (list 'expose-event #'layout-expose :object t))))
 682
 683     (with-slots (hadjustment vadjustment) layout
 684       (setf
 685        (adjustment-step-increment hadjustment) 10.0
 686        (adjustment-step-increment vadjustment) 10.0))
 687
 688     (dotimes (i 16)
 689       (dotimes (j 16)
 690         (let ((text (format nil "Button ~D, ~D" i j)))
 691           (layout-put layout
 692            (make-instance (if (not (zerop (mod (+ i j) 2)))
 693                               'button
 694                             'label)
 695                           :label text :visible t)
 696            (* j 100) (* i 100)))))
 697
 698     (loop
 699      for i from 16 below 1280
 700      do (let ((text (format nil "Button ~D, ~D" i 0)))
 701           (layout-put layout
 702            (make-instance (if (not (zerop (mod i 2)))
 703                               'button
 704                             'label)
 705                           :label text :visible t)
 706            0 (* i 100))))))
 707
 708
 709
 710 ;;; List
 711
 712 (define-simple-dialog create-list (dialog "List" :default-height 400)
 713   (let* ((store (make-instance 'list-store
 714                  :column-types '(string integer boolean)
 715                  :column-names '(:foo :bar :baz)
 716                  :initial-content '(#("First" 12321 nil)
 717                                     (:foo "Yeah" :baz t))))
 718          (tree (make-instance 'tree-view :model store)))
 719
 720     (loop
 721      with iter = (make-instance 'tree-iter)
 722      for i from 1 to 1000
 723      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 724
 725     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 726           (cell (make-instance 'cell-renderer-text)))
 727       (cell-layout-pack column cell :expand t)
 728       (cell-layout-add-attribute column cell 'text (column-index store :foo))
 729       (tree-view-append-column tree column))
 730
 731     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 732           (cell (make-instance 'cell-renderer-text :background "orange")))
 733       (cell-layout-pack column cell :expand t)
 734       (cell-layout-add-attribute column cell 'text (column-index store :bar))
 735       (tree-view-append-column tree column))
 736
 737     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 738           (cell (make-instance 'cell-renderer-text)))
 739       (cell-layout-pack column cell :expand t)
 740       (cell-layout-add-attribute column cell 'text (column-index store :baz))
 741       (tree-view-append-column tree column))
 742
 743     (make-instance 'v-box
 744      :parent dialog :border-width 10 :spacing 10
 745      :child (list
 746              (make-instance 'h-box
 747               :spacing 10
 748               :child (make-instance 'button
 749                       :label "Remove Selection"
 750                       :signal (list 'clicked
 751                                #'(lambda ()
 752                                    (let ((references
 753                                           (mapcar
 754                                            #'(lambda (path)
 755                                                (make-instance 'tree-row-reference :model store :path path))
 756                                            (tree-selection-get-selected-rows
 757                                             (tree-view-selection tree)))))
 758                                      (mapc
 759                                       #'(lambda (reference)
 760                                           (list-store-remove store reference))
 761                                       references))))))
 762              :expand nil)
 763      :child (list
 764              (make-instance 'h-box
 765               :spacing 10
 766               :child (make-instance 'check-button
 767                       :label "Show Headers" :active t
 768                       :signal (list 'toggled
 769                                #'(lambda (button)
 770                                    (setf
 771                                     (tree-view-headers-visible-p tree)
 772                                     (toggle-button-active-p button)))
 773                                :object t))
 774               :child (make-instance 'check-button
 775                       :label "Reorderable" :active nil
 776                       :signal (list 'toggled
 777                                #'(lambda (button)
 778                                    (setf
 779                                     (tree-view-reorderable-p tree)
 780                                     (toggle-button-active-p button)))
 781                                :object t))
 782               :child (list
 783                       (make-instance 'h-box
 784                        :child (make-instance 'label :label "Selection Mode: ")
 785                        :child (make-instance 'combo-box
 786                                :content '("Single" "Browse" "Multiple")
 787                                :active 0
 788                                :signal (list 'changed
 789                                         #'(lambda (combo-box)
 790                                             (setf
 791                                              (tree-selection-mode
 792                                               (tree-view-selection tree))
 793                                              (svref
 794                                               #(:single :browse :multiple)
 795                                               (combo-box-active combo-box))))
 796                                         :object t)))
 797                       :expand nil))
 798              :expand nil)
 799      :child (make-instance 'scrolled-window
 800             :child tree :hscrollbar-policy :automatic))))
 801
 802
 803 ;; Menus
 804
 805 (defun create-menu (depth tearoff)
 806   (unless (zerop depth)
 807     (let ((menu (make-instance 'menu)))
 808       (when tearoff
 809         (let ((menu-item (make-instance 'tearoff-menu-item)))
 810           (menu-shell-append menu menu-item)))
 811       (let ((group nil))
 812         (dotimes (i 5)
 813           (let ((menu-item
 814                  (make-instance 'radio-menu-item
 815                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 816             (if group
 817                 (add-to-radio-group menu-item group)
 818               (setq group menu-item))
 819             (unless (zerop (mod depth 2))
 820               (setf (check-menu-item-active-p menu-item) t))
 821             (menu-shell-append menu menu-item)
 822             (when (= i 3)
 823               (setf (widget-sensitive-p menu-item) nil))
 824             (let ((submenu (create-menu (1- depth) t)))
 825               (when submenu
 826                 (setf (menu-item-submenu menu-item) submenu))))))
 827       menu)))
 828
 829
 830 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 831   (let* ((main (make-instance 'v-box :parent dialog))
 832 ;        (accel-group (make-instance 'accel-group))
 833          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 834 ;    (window-add-accel-group dialog accel-group)
 835
 836     (let ((menu-item (make-instance 'menu-item
 837                       :label (format nil "test~%line2"))))
 838       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 839       (menu-shell-append menubar menu-item))
 840
 841     (let ((menu-item (make-instance 'menu-item :label "foo")))
 842       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 843       (menu-shell-append menubar menu-item))
 844
 845     (let ((menu-item (make-instance 'menu-item :label "bar")))
 846       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 847       (setf (menu-item-right-justified-p menu-item) t)
 848       (menu-shell-append menubar menu-item))
 849
 850     (make-instance 'v-box
 851      :spacing 10 :border-width 10 :parent main
 852      :child (make-instance 'combo-box
 853              :active 3
 854              :content (loop
 855                        for i from 1 to 5
 856                        collect (format nil "Item ~D" i))))
 857
 858     (widget-show-all main)))
 859
 860
 861 ;;; Notebook
 862
 863 (defun create-notebook-page (notebook page-num book-closed)
 864   (let* ((title (format nil "Page ~D" page-num))
 865          (page (make-instance 'frame :label title :border-width 10))
 866          (v-box (make-instance 'v-box
 867                  :homogeneous t :border-width 10 :parent page)))
 868
 869     (make-instance 'h-box
 870      :parent (list v-box :fill nil :padding 5) :homogeneous t
 871      :child-args '(:padding 5)
 872      :child (make-instance 'check-button
 873              :label "Fill Tab" :active t
 874              :signal (list 'toggled
 875                            #'(lambda (button)
 876                                (setf
 877                                 (notebook-child-tab-fill-p page)
 878                                 (toggle-button-active-p button)))
 879                            :object t))
 880      :child (make-instance 'check-button
 881              :label "Expand Tab"
 882              :signal (list 'toggled
 883                            #'(lambda (button)
 884                                (setf
 885                                 (notebook-child-tab-expand-p page)
 886                                 (toggle-button-active-p button)))
 887                            :object t))
 888      :child (make-instance 'check-button
 889              :label "Pack end"
 890              :signal (list 'toggled
 891                            #'(lambda (button)
 892                                (setf
 893                                 (notebook-child-tab-pack page)
 894                                 (if (toggle-button-active-p button)
 895                                     :end
 896                                   :start)))
 897                            :object t))
 898      :child (make-instance 'button
 899              :label "Hide page"
 900              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 901
 902     (let ((label-box (make-instance 'h-box
 903                       :show-children t
 904                       :child-args '(:expand nil)
 905                       :child (make-instance 'image :pixbuf book-closed)
 906                       :child (make-instance 'label :label title)))
 907           (menu-box (make-instance 'h-box
 908                      :show-children t
 909                      :child-args '(:expand nil)
 910                      :child (make-instance 'image :pixbuf book-closed)
 911                      :child (make-instance 'label :label title))))
 912
 913       (widget-show-all page)
 914       (notebook-append notebook page label-box menu-box))))
 915
 916
 917 (define-simple-dialog create-notebook (dialog "Notebook")
 918   (let ((main (make-instance 'v-box :parent dialog)))
 919     (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
 920           (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
 921           (notebook (make-instance 'notebook
 922                      :border-width 10 :tab-pos :top :parent main)))
 923       (flet ((set-image (page func pixbuf)
 924                (setf
 925                 (image-pixbuf
 926                  (first (container-children (funcall func notebook page))))
 927                 pixbuf)))
 928         (signal-connect notebook 'switch-page
 929          #'(lambda (pointer page)
 930              (declare (ignore pointer))
 931              (set-image page #'notebook-menu-label book-open)
 932              (set-image page #'notebook-tab-label book-open)
 933              (when (slot-boundp notebook 'current-page)
 934                (let ((curpage (notebook-current-page notebook)))
 935                  (set-image curpage #'notebook-menu-label book-closed)
 936                  (set-image curpage #'notebook-tab-label book-closed))))))
 937       (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 938
 939       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 940
 941       (make-instance 'h-box
 942        :spacing 5 :border-width 10
 943        :parent (list main :expand nil)
 944        :child-args '(:fill nil)
 945        :child (make-instance 'check-button
 946                :label "Popup menu"
 947                :signal (list 'clicked
 948                         #'(lambda (button)
 949                             (if (toggle-button-active-p button)
 950                                 (notebook-popup-enable notebook)
 951                                 (notebook-popup-disable notebook)))
 952                         :object t))
 953        :child (make-instance 'check-button
 954                :label "Homogeneous tabs"
 955                :signal (list 'clicked
 956                         #'(lambda (button)
 957                             (setf
 958                              (notebook-homogeneous-p notebook)
 959                              (toggle-button-active-p button)))
 960                         :object t)))
 961
 962       (make-instance 'h-box
 963        :spacing 5 :border-width 10
 964        :parent (list main :expand nil)
 965        :child-args '(:expand nil)
 966        :child (make-instance 'label :label "Notebook Style: ")
 967        :child (let ((scrollable-p nil))
 968                 (make-instance 'combo-box
 969                  :content '("Standard" "No tabs" "Scrollable") :active 0
 970                  :signal (list 'changed
 971                           #'(lambda (combo-box)
 972                               (case (combo-box-active combo-box)
 973                                 (0
 974                                  (setf (notebook-show-tabs-p notebook) t)
 975                                  (when scrollable-p
 976                                    (setq scrollable-p nil)
 977                                    (setf (notebook-scrollable-p notebook) nil)
 978                                    (loop repeat 10
 979                                     do (notebook-remove-page notebook 5))))
 980                                 (1
 981                                  (setf (notebook-show-tabs-p notebook) nil)
 982                                  (when scrollable-p
 983                                    (setq scrollable-p nil)
 984                                    (setf (notebook-scrollable-p notebook) nil)
 985                                    (loop repeat 10
 986                                      do (notebook-remove-page notebook 5))))
 987                                 (2
 988                                  (unless scrollable-p
 989                                    (setq scrollable-p t)
 990                                    (setf (notebook-show-tabs-p notebook) t)
 991                                    (setf (notebook-scrollable-p notebook) t)
 992                                    (loop for i from 6 to 15
 993                                     do (create-notebook-page notebook i book-closed))))))
 994                           :object t)))
 995        :child (make-instance 'button
 996                :label "Show all Pages"
 997                :signal (list 'clicked
 998                         #'(lambda ()
 999                             (map-container nil #'widget-show notebook)))))
1000
1001       (make-instance 'h-box
1002        :spacing 5 :border-width 10
1003        :parent (list main :expand nil)
1004        :child (make-instance 'button
1005                :label "prev"
1006                :signal (list 'clicked #'notebook-prev-page :object notebook))
1007        :child (make-instance 'button
1008                :label "next"
1009                :signal (list 'clicked #'notebook-next-page :object notebook))
1010        :child (make-instance 'button
1011                :label "rotate"
1012                :signal (let ((tab-pos 0))
1013                          (list 'clicked
1014                           #'(lambda ()
1015                               (setq tab-pos (mod (1+ tab-pos) 4))
1016                               (setf
1017                                (notebook-tab-pos notebook)
1018                                (svref #(:top :right :bottom :left) tab-pos))))))))
1019     (widget-show-all main)))
1020
1021
1022 ;;; Panes
1023
1024 (defun toggle-resize (child)
1025   (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1026
1027 (defun toggle-shrink (child)
1028   (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1029
1030 (defun create-pane-options (paned frame-label label1 label2)
1031   (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1032     (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1033     (let ((check-button (make-instance 'check-button :label "Resize")))
1034       (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1035       (signal-connect check-button 'toggled
1036        #'toggle-resize :object (paned-child1 paned)))
1037     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1038       (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1039       (signal-connect check-button 'toggled
1040        #'toggle-shrink :object (paned-child1 paned)))
1041
1042     (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1043     (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1044       (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1045       (signal-connect check-button 'toggled
1046        #'toggle-resize :object (paned-child2 paned)))
1047     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1048       (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1049       (signal-connect check-button 'toggled
1050        #'toggle-shrink :object (paned-child2 paned)))
1051     (make-instance 'frame :label frame-label :border-width 4 :child table)))
1052
1053 (define-toplevel create-panes (window "Panes")
1054   (let* ((hpaned (make-instance 'h-paned
1055                   :child1 (make-instance 'frame
1056                            :width-request 60 :height-request 60
1057                            :shadow-type :in
1058                            :child (make-instance 'button :label "Hi there"))
1059                   :child2 (make-instance 'frame
1060                            :width-request 80 :height-request 60
1061                            :shadow-type :in)))
1062          (vpaned (make-instance 'v-paned
1063                   :border-width 5
1064                   :child1 hpaned
1065                   :child2 (make-instance 'frame
1066                            :width-request 80 :height-request 60
1067                            :shadow-type :in))))
1068
1069     (make-instance 'v-box
1070      :parent window
1071      :child-args '(:expand nil)
1072      :child (list vpaned :expand t)
1073      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1074      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1075
1076
1077 ;;; Progress bar
1078
1079 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1080   (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1081          (activity-mode-button (make-instance 'check-button
1082                                 :label "Activity mode"))
1083          (timer (timeout-add 100
1084                  #'(lambda ()
1085                      (if (toggle-button-active-p activity-mode-button)
1086                          (progress-bar-pulse progress)
1087                        (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1088                          (setf
1089                           (progress-bar-fraction progress)
1090                           (if (> fract 1.0)
1091                               0.0
1092                             fract))))
1093                      t))))
1094
1095     (make-instance 'v-box
1096      :parent dialog :border-width 10 :spacing 10
1097      :child progress
1098      :child activity-mode-button)
1099
1100     (signal-connect dialog 'destroy
1101      #'(lambda () (when timer (timeout-remove timer))))))
1102
1103
1104 ;;; Radio buttons
1105
1106 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1107   (make-instance 'v-box
1108    :parent dialog :border-width 10 :spacing 10
1109    :children (make-radio-group 'radio-button
1110               '((:label "button1") (:label "button2") (:label "button3"))
1111               nil)))
1112
1113
1114 ;;; Rangle controls
1115
1116 (define-simple-dialog create-range-controls (dialog "Range controls")
1117   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1118     (make-instance 'v-box
1119      :parent dialog :border-width 10 :spacing 10
1120      :child (make-instance 'h-scale
1121              :width-request 150 :adjustment adjustment :inverted t
1122              :update-policy :delayed :digits 1 :draw-value t)
1123      :child (make-instance 'h-scrollbar
1124              :adjustment adjustment :update-policy :continuous))))
1125
1126
1127 ;;; Reparent test
1128
1129 (define-simple-dialog create-reparent (dialog "Reparent")
1130   (let ((main (make-instance 'h-box
1131                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1132         (label (make-instance 'label :label "Hello World")))
1133
1134     (flet ((create-frame (title)
1135              (let* ((frame (make-instance 'frame :label title :parent main))
1136                     (box (make-instance 'v-box
1137                           :spacing 5 :border-width 5 :parent frame))
1138                     (button (make-instance 'button
1139                              :label "switch" :parent (list box :expand nil))))
1140                (signal-connect button 'clicked
1141                 #'(lambda ()
1142                     (widget-reparent label box)))
1143                box)))
1144
1145       (box-pack-start (create-frame "Frame 1") label nil t 0)
1146       (create-frame "Frame 2"))
1147     (widget-show-all main)))
1148
1149
1150 ;;; Rulers
1151
1152 (define-toplevel create-rulers (window "Rulers"
1153                                 :default-width 300 :default-height 300
1154                                 :events '(:pointer-motion :pointer-motion-hint))
1155   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1156         (h-ruler (make-instance 'h-ruler
1157                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1158                   :position 0.0d0 :max-size 20.0d0))
1159         (v-ruler (make-instance 'v-ruler
1160                   :lower 5.0d0 :upper 15.0d0
1161                   :position 0.0d0 :max-size 20.0d0)))
1162     (signal-connect window 'motion-notify-event
1163      #'(lambda (event)
1164          (widget-event h-ruler event)
1165          (widget-event v-ruler event)))
1166     (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1167     (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1168
1169
1170 ;;; Scrolled window
1171
1172 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1173                                                       :default-width 300
1174                                                       :default-height 300)
1175   (let* ((scrolled-window
1176           (make-instance 'scrolled-window
1177            :parent dialog :border-width 10
1178            :vscrollbar-policy :automatic
1179            :hscrollbar-policy :automatic))
1180          (table
1181           (make-instance 'table
1182            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1183            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1184            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1185
1186       (scrolled-window-add-with-viewport scrolled-window table)
1187       (dotimes (i 20)
1188         (dotimes (j 20)
1189           (let ((button
1190                  (make-instance 'toggle-button
1191                   :label (format nil "button (~D,~D)~%" i j))))
1192             (table-attach table button i (1+ i) j (1+ j)))))
1193       (widget-show-all scrolled-window)))
1194
1195
1196 ;;; Size group
1197
1198 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1199   (let ((size-group (make-instance 'size-group)))
1200     (flet ((create-frame (label rows)
1201              (let ((table (make-instance 'table
1202                            :n-rows (length rows) :n-columns 2 :homogeneous nil
1203                            :row-spacing 5 :column-spacing 10 :border-width 5)))
1204                (loop
1205                 for row in rows
1206                 for i from 0
1207                 do (table-attach table
1208                     (create-label (first row) :xalign 0 :yalign 1)
1209                     0 1 i (1+ i) :x-options '(:expand :fill))
1210                    (let ((combo (make-instance 'combo-box
1211                                  :content (rest row) :active 0)))
1212                      (size-group-add-widget size-group combo)
1213                      (table-attach table combo 1 2 i (1+ i))))
1214                (make-instance 'frame :label label :child table))))
1215
1216       (make-instance 'v-box
1217        :parent dialog :border-width 5 :spacing 5
1218        :child (create-frame "Color Options"
1219                '(("Foreground" "Red" "Green" "Blue")
1220                  ("Background" "Red" "Green" "Blue")))
1221        :child (create-frame "Line Options"
1222                '(("Dashing" "Solid" "Dashed" "Dotted")
1223                  ("Line ends" "Square" "Round" "Arrow")))
1224        :child (create-check-button "Enable grouping"
1225                #'(lambda (active)
1226                    (setf
1227                     (size-group-mode size-group)
1228                     (if active :horizontal :none)))
1229                t)))))
1230
1231
1232 ;;; Shapes
1233
1234 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1235   (let ((window
1236          (make-instance 'window
1237           :type type :default-width 100 :default-height 100
1238           :events '(:button-motion :pointer-motion-hint :button-press)
1239           :signal (list 'destroy destroy))))
1240
1241     (widget-realize window)
1242     (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1243       (let ((fixed (make-instance 'fixed :parent window)))
1244         (fixed-put fixed (create-image-widget source mask) px py))
1245       (widget-shape-combine-mask window mask px py))
1246
1247     (let ((x-offset 0)
1248           (y-offset 0))
1249       (declare (fixnum x-offset y-offset))
1250       (signal-connect window 'button-press-event
1251        #'(lambda (event)
1252            (when (typep event 'gdk:button-press-event)
1253              (setq x-offset (truncate (gdk:event-x event)))
1254              (setq y-offset (truncate (gdk:event-y event)))
1255              (grab-add window)
1256              (gdk:pointer-grab (widget-window window)
1257               :events '(:button-release :button-motion :pointer-motion-hint)
1258               :owner-events t :time event))))
1259
1260       (signal-connect window 'button-release-event
1261        #'(lambda (event)
1262            (grab-remove window)
1263            (gdk:pointer-ungrab event)))
1264
1265       (signal-connect window 'motion-notify-event
1266        #'(lambda (event)
1267            (declare (ignore event))
1268            (multiple-value-bind (win xp yp mask)
1269                (gdk:window-get-pointer root-window)
1270              (declare (ignore mask win) (fixnum xp yp))
1271              (window-move window (- xp x-offset) (- yp y-offset))))))
1272
1273     (window-move window x y)
1274     (widget-show-all window)
1275     window))
1276
1277
1278 (let ((modeller nil)
1279       (sheets nil)
1280       (rings nil))
1281   (defun create-shapes ()
1282     (let ((root-window (gdk:get-root-window)))
1283       (if (not modeller)
1284           (setq
1285            modeller
1286            (create-shape-icon
1287             "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1288             #'(lambda () (setq modeller nil))))
1289         (widget-destroy modeller))
1290
1291       (if (not sheets)
1292           (setq
1293            sheets
1294            (create-shape-icon
1295             "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1296             #'(lambda () (setq sheets nil))))
1297         (widget-destroy sheets))
1298
1299       (if (not rings)
1300           (setq
1301            rings
1302            (create-shape-icon
1303             "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1304             #'(lambda () (setq rings nil))))
1305         (widget-destroy rings)))))
1306
1307
1308
1309 ;;; Spin buttons
1310
1311 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1312   (let ((main (make-instance 'v-box
1313                :spacing 5 :border-width 10 :parent dialog)))
1314
1315     (flet ((create-date-spinner (label adjustment shadow-type)
1316              (declare (ignore shadow-type))
1317              (make-instance 'v-box
1318               :child-args '(:expand nil)
1319               :child (make-instance 'label
1320                       :label label :xalign 0.0 :yalign 0.5)
1321               :child (make-instance 'spin-button
1322                       :adjustment adjustment :wrap t))))
1323       (multiple-value-bind (sec min hour date month year day daylight-p zone)
1324           (get-decoded-time)
1325         (declare (ignore sec min hour day daylight-p zone))
1326         (make-instance 'frame
1327          :label "Not accelerated" :parent main
1328          :child (make-instance 'h-box
1329                  :border-width 10
1330                  :child-args '(:padding 5)
1331                  :child (create-date-spinner "Day : "
1332                          (adjustment-new date 1 31 1 5 0) :out)
1333                  :child (create-date-spinner "Month : "
1334                          (adjustment-new month 1 12 1 5 0) :etched-in)
1335                  :child (create-date-spinner "Year : "
1336                          (adjustment-new year 0 2100 1 100 0) :in)))))
1337
1338     (let ((spinner1 (make-instance 'spin-button
1339                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1340                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1341           (spinner2 (make-instance 'spin-button
1342                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1343                      :climb-rate 1.0 :wrap t))
1344           (value-label (make-instance 'label :label "0")))
1345       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1346        #'(lambda ()
1347            (setf
1348             (spin-button-digits spinner1)
1349             (floor (spin-button-value spinner2)))))
1350
1351       (make-instance 'frame
1352        :label "Accelerated" :parent main
1353        :child (make-instance 'v-box
1354                :border-width 5
1355                :child (list
1356                        (make-instance 'h-box
1357                         :child-args '(:padding 5)
1358                         :child (make-instance 'v-box
1359                                 :child (make-instance 'label
1360                                         :label "Value :"
1361                                         :xalign 0.0 :yalign 0.5)
1362                                 :child spinner1)
1363                         :child (make-instance 'v-box
1364                                 :child (make-instance 'label
1365                                         :label "Digits :"
1366                                         :xalign 0.0 :yalign 0.5)
1367                                 :child spinner2))
1368                        :expand nil :padding 5)
1369                :child (make-instance 'check-button
1370                        :label "Snap to 0.5-ticks" :active t
1371                        :signal (list 'clicked
1372                                 #'(lambda (button)
1373                                     (setf
1374                                      (spin-button-snap-to-ticks-p spinner1)
1375                                      (toggle-button-active-p button)))
1376                                 :object t))
1377                :child (make-instance 'check-button
1378                        :label "Numeric only input mode" :active t
1379                        :signal (list 'clicked
1380                                 #'(lambda (button)
1381                                     (setf
1382                                      (spin-button-numeric-p spinner1)
1383                                      (toggle-button-active-p button)))
1384                                 :object t))
1385                :child value-label
1386                :child (list
1387                        (make-instance 'h-box
1388                         :child-args '(:padding 5)
1389                         :child (make-instance 'button
1390                                 :label "Value as Int"
1391                                 :signal (list 'clicked
1392                                          #'(lambda ()
1393                                              (setf
1394                                               (label-label value-label)
1395                                               (format nil "~D"
1396                                                (spin-button-value-as-int
1397                                                 spinner1))))))
1398                         :child (make-instance 'button
1399                                 :label "Value as Float"
1400                                 :signal (list 'clicked
1401                                          #'(lambda ()
1402                                              (setf
1403                                               (label-label value-label)
1404                                               (format nil
1405                                                (format nil "~~,~DF"
1406                                                 (spin-button-digits spinner1))
1407                                                (spin-button-value spinner1)))))))
1408                        :padding 5 :expand nil))))
1409     (widget-show-all main)))
1410
1411
1412 ;;; Statusbar
1413
1414 (define-toplevel create-statusbar (window "Statusbar")
1415   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1416         (close-button (create-button '("close" :can-default t)
1417                        #'widget-destroy :object window))
1418         (counter 0))
1419
1420     (signal-connect statusbar 'text-popped
1421      #'(lambda (context-id text)
1422          (declare (ignore context-id))
1423          (format nil "Popped: ~A~%" text)))
1424
1425     (make-instance 'v-box
1426      :parent window
1427      :child (make-instance 'v-box
1428              :border-width 10 :spacing 10
1429              :child (create-button "push something"
1430                      #'(lambda ()
1431                          (statusbar-push statusbar 1
1432                           (format nil "something ~D" (incf counter)))))
1433              :child (create-button "pop"
1434                      #'(lambda ()
1435                          (statusbar-pop statusbar 1)))
1436              :child (create-button "steal #4"
1437                      #'(lambda ()
1438                          (statusbar-remove statusbar 1 4)))
1439              :child (create-button "dump stack")
1440              :child (create-button "test contexts"))
1441      :child (list (make-instance 'h-separator) :expand nil)
1442      :child (list
1443              (make-instance 'v-box :border-width 10 :child close-button)
1444              :expand nil)
1445      :child (list statusbar :expand nil))
1446
1447     (widget-grab-focus close-button)))
1448
1449
1450 ;;; Idle test
1451
1452 (define-simple-dialog create-idle-test (dialog "Idle Test")
1453   (let ((label (make-instance 'label
1454                 :label "count: 0" :xpad 10 :ypad 10))
1455         (idle nil)
1456         (count 0))
1457     (signal-connect dialog 'destroy
1458      #'(lambda () (when idle (idle-remove idle))))
1459
1460     (make-instance 'v-box
1461      :parent dialog :border-width 10 :spacing 10
1462      :child label
1463      :child (make-instance 'frame
1464              :label "Label Container" :border-width 5
1465              :child(make-instance 'v-box
1466                    :children (make-radio-group 'radio-button
1467                               '((:label "Resize-Parent" :value :parent :active t)
1468                                 (:label "Resize-Queue" :value :queue)
1469                                 (:label "Resize-Immediate" :value :immediate))
1470                               #'(lambda (mode)
1471                                   (setf
1472                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1473
1474     (dialog-add-button dialog "Start"
1475      #'(lambda ()
1476          (unless idle
1477            (setq idle
1478             (idle-add
1479              #'(lambda ()
1480                  (incf count)
1481                  (setf (label-label label) (format nil "count: ~D" count))
1482                  t))))))
1483
1484     (dialog-add-button dialog "Stop"
1485      #'(lambda ()
1486          (when idle
1487            (idle-remove idle)
1488            (setq idle nil))))))
1489
1490
1491
1492 ;;; Timeout test
1493
1494 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1495   (let ((label (make-instance 'label
1496                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1497         (timer nil)
1498         (count 0))
1499     (signal-connect dialog 'destroy
1500      #'(lambda () (when timer (timeout-remove timer))))
1501
1502     (dialog-add-button dialog "Start"
1503      #'(lambda ()
1504          (unless timer
1505            (setq timer
1506             (timeout-add 100
1507              #'(lambda ()
1508                  (incf count)
1509                  (setf (label-label label) (format nil "count: ~D" count))
1510                  t))))))
1511
1512     (dialog-add-button dialog "Stop"
1513      #'(lambda ()
1514          (when timer
1515            (timeout-remove timer)
1516            (setq timer nil))))))
1517
1518
1519 ;;; Text
1520
1521 (define-simple-dialog create-text (dialog "Text" :default-width 400
1522                                                  :default-height 400)
1523   (let* ((text-view (make-instance 'text-view
1524                      :border-width 10 :visible t :wrap-mode :word))
1525          (buffer (text-view-buffer text-view))
1526          (active-tags ()))
1527
1528     (text-buffer-create-tag buffer "Bold" :weight :bold)
1529     (text-buffer-create-tag buffer "Italic" :style :italic)
1530     (text-buffer-create-tag buffer "Underline" :underline :single)
1531
1532     (flet ((create-toggle-callback (tag-name)
1533              (let ((tag (text-tag-table-lookup
1534                          (text-buffer-tag-table buffer) tag-name)))
1535                #'(lambda (active)
1536                    (unless (eq (and (find tag active-tags) t) active)
1537                      ;; user activated
1538                      (if active
1539                          (push tag active-tags)
1540                        (setq active-tags (delete tag active-tags)))
1541                      (multiple-value-bind (non-zero-p start end)
1542                          (text-buffer-get-selection-bounds buffer)
1543                        (declare (ignore non-zero-p))
1544                        (if active
1545                            (text-buffer-apply-tag buffer tag start end)
1546                          (text-buffer-remove-tag buffer tag start end))))))))
1547
1548       (let* ((actions
1549               (make-instance 'action-group
1550                :action (create-toggle-action
1551                         "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1552                         (create-toggle-callback "Bold"))
1553                :action (create-toggle-action
1554                         "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1555                         (create-toggle-callback "Italic"))
1556                :action (create-toggle-action
1557                         "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1558                         (create-toggle-callback "Underline"))))
1559              (ui (make-instance 'ui-manager)))
1560
1561         (ui-manager-insert-action-group ui actions)
1562         (ui-manager-add-ui ui
1563          '((:toolbar "ToolBar"
1564             (:toolitem "Bold")
1565             (:toolitem "Italic")
1566             (:toolitem "Underline"))))
1567
1568         ;; Callback to activate/deactivate toolbar buttons when cursor
1569         ;; is moved
1570         (signal-connect buffer 'mark-set
1571          #'(lambda (location mark)
1572              (declare (ignore mark))
1573              (text-tag-table-foreach (text-buffer-tag-table buffer)
1574               #'(lambda (tag)
1575                   (let ((active
1576                          (or
1577                           (and
1578                            (text-iter-has-tag-p location tag)
1579                            (not (text-iter-begins-tag-p location tag)))
1580                           (text-iter-ends-tag-p location tag))))
1581                     (unless (eq active (and (find tag active-tags) t))
1582                       (if active
1583                           (push tag active-tags)
1584                         (setq active-tags (delete tag active-tags)))
1585                       (setf
1586                        (toggle-action-active-p
1587                         (action-group-get-action actions (text-tag-name tag)))
1588                        active)))))))
1589
1590         ;; Callback to apply active tags when a character is inserted
1591         (signal-connect buffer 'insert-text
1592          #'(lambda (iter &rest args)
1593              (declare (ignore args))
1594              (let ((before (text-buffer-get-iter-at-offset buffer
1595                             (1- (text-iter-offset iter)))))
1596                (loop
1597                 for tag in active-tags
1598                 do (text-buffer-apply-tag buffer tag before iter))))
1599          :after t)
1600
1601         (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1602         (container-add dialog text-view)))))
1603
1604
1605 ;;; Toggle buttons
1606
1607 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1608   (make-instance 'v-box
1609    :border-width 10 :spacing 10 :parent dialog
1610       :children (loop
1611               for n from 1 to 3
1612               collect (make-instance 'toggle-button
1613                        :label (format nil "Button~D" (1+ n))))))
1614
1615
1616
1617 ;;; Toolbar test
1618
1619 (defun create-toolbar (window)
1620   (make-instance 'toolbar
1621    :show-tooltips t :show-arrow nil
1622
1623    ;; Insert a stock item
1624    :child (make-instance 'tool-button
1625            :stock  "gtk-quit"
1626            :tip-text "Destroy toolbar"
1627            :tip-private "Toolbar/Quit"
1628            :signal (list 'clicked #'(lambda () (widget-destroy window))))
1629
1630    :child (make-instance 'separator-tool-item)
1631
1632    :child (make-instance 'tool-button
1633            :label "Horizontal" :stock "gtk-go-forward"
1634            :tip-text "Horizontal toolbar layout"
1635            :tip-private "Toolbar/Horizontal"
1636            :signal (list 'clicked
1637                     #'(lambda (toolbar)
1638                         (setf (toolbar-orientation toolbar) :horizontal))
1639                     :object :parent))
1640
1641    :child (make-instance 'tool-button
1642            :label "Vertical" :stock "gtk-go-down"
1643            :tip-text "Vertical toolbar layout"
1644            :tip-private "Toolbar/Vertical"
1645            :signal (list 'clicked
1646                     #'(lambda (toolbar)
1647                         (setf (toolbar-orientation toolbar) :vertical))
1648                     :object :parent))
1649
1650    :child (make-instance 'separator-tool-item)
1651
1652    :children (make-radio-group 'radio-tool-button
1653               '((:label "Icons" :stock "gtk-justify-left"
1654                  :tip-text "Only show toolbar icons"
1655                  :tip-private "Toolbar/IconsOnly"
1656                  :value :icons)
1657                 (:label "Both" :stock "gtk-justify-center"
1658                  :tip-text "Show toolbar icons and text"
1659                  :tip-private "Toolbar/Both"
1660                  :value :both :active t)
1661                 (:label "Text" :stock "gtk-justify-right"
1662                  :tip-text "Show toolbar text"
1663                  :tip-private "Toolbar/TextOnly"
1664                  :value :text))
1665               (list
1666                #'(lambda (toolbar style)
1667                    (setf (toolbar-style toolbar) style))
1668                :object :parent))
1669
1670    :child (make-instance 'separator-tool-item)
1671
1672    :child (make-instance 'tool-item
1673            :child (make-instance 'entry)
1674            :tip-text "This is an unusable GtkEntry"
1675            :tip-private "Hey don't click me!")
1676
1677    :child (make-instance 'separator-tool-item)
1678
1679    :child (make-instance 'tool-button
1680            :label "Enable" :stock "gtk-add"
1681            :tip-text "Enable tooltips"
1682            :tip-private "Toolbar/EnableTooltips"
1683            :signal (list 'clicked
1684                     #'(lambda (toolbar)
1685                         (setf (toolbar-show-tooltips-p toolbar) t))
1686                     :object :parent))
1687
1688    :child (make-instance 'tool-button
1689            :label "Disable" :stock "gtk-remove"
1690            :tip-text "Disable tooltips"
1691            :tip-private "Toolbar/DisableTooltips"
1692            :signal (list 'clicked
1693                     #'(lambda (toolbar)
1694                         (setf (toolbar-show-tooltips-p toolbar) nil))
1695                     :object :parent))
1696
1697 ;;    :child (make-instance 'separator-tool-item)
1698
1699 ;;    :child (make-instance 'tool-button
1700 ;;         :label "GTK" :icon #p"clg:examples;gtk.png"
1701 ;;         :tip-text "GTK+ Logo"
1702 ;;         :tip-private "Toolbar/GTK+")
1703    ))
1704
1705 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1706   (container-add window (create-toolbar window)))
1707
1708
1709 ;;; Handle box
1710
1711 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1712   (make-instance 'v-box
1713    :parent window
1714    :child (create-label "Above")
1715    :child (make-instance 'h-separator)
1716    :child (make-instance 'h-box
1717            :spacing 10
1718            :child (list
1719                    (make-instance 'handle-box
1720                     :child (create-toolbar window)
1721                     :signal (list 'child-attached
1722                              #'(lambda (child)
1723                                  (format t "~A attached~%" child)))
1724                     :signal (list 'child-detached
1725                              #'(lambda (child)
1726                                  (format t "~A detached~%" child))))
1727                    :expand nil :fill :nil))
1728    :child (make-instance 'h-separator)
1729    :child (create-label "Below")))
1730
1731
1732 ;;; Tooltips test
1733
1734 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1735   (let ((tooltips (make-instance 'tooltips)))
1736     (flet ((create-button (label tip-text tip-private)
1737              (let ((button (make-instance 'toggle-button :label label)))
1738                (tooltips-set-tip tooltips button tip-text tip-private)
1739                button)))
1740       (make-instance 'v-box
1741        :parent dialog :border-width 10 :spacing 10
1742        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1743        :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")))))
1744
1745
1746 ;;; UI Manager
1747
1748 (defvar *ui-description*
1749   '((:menubar "MenuBar"
1750      (:menu "FileMenu"
1751       (:menuitem "New")
1752       (:menuitem "Open")
1753       (:menuitem "Save")
1754       (:menuitem "SaveAs")
1755       :separator
1756       (:menuitem "Quit"))
1757      (:menu "PreferencesMenu"
1758        (:menu "ColorMenu"
1759         (:menuitem "Red")
1760         (:menuitem "Green")
1761         (:menuitem "Blue"))
1762        (:menu "ShapeMenu"
1763         (:menuitem "Square")
1764         (:menuitem "Rectangle")
1765         (:menuitem "Oval"))
1766        (:menuitem "Bold"))
1767      (:menu "HelpMenu"
1768       (:menuitem "About")))
1769     (:toolbar "ToolBar"
1770      (:toolitem "Open")
1771      (:toolitem "Quit")
1772      (:separator "Sep1")
1773      (:toolitem "Logo"))))
1774
1775 (define-toplevel create-ui-manager (window "UI Manager")
1776   (let ((actions
1777          (make-instance 'action-group
1778           :name "Actions"
1779           :action (create-action "FileMenu" nil "_File")
1780           :action (create-action "PreferencesMenu" nil "_Preferences")
1781           :action (create-action "ColorMenu" nil "_Color")
1782           :action (create-action "ShapeMenu" nil "_Shape")
1783           :action (create-action "HelpMenu" nil "_Help")
1784           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1785           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
1786           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1787           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1788           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
1789           :action (create-action "About" nil "_About" "<control>A" "About")
1790           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1791           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1792           :actions (create-radio-actions
1793                     '(("Red" nil "_Red" "<control>R" "Blood")
1794                       ("Green" nil "_Green" "<control>G" "Grass")
1795                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1796                     "Green")
1797           :actions (create-radio-actions
1798                     '(("Square" nil "_Square" "<control>S" "Square")
1799                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1800                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1801         (ui (make-instance 'ui-manager)))
1802
1803     (ui-manager-insert-action-group ui actions)
1804     (ui-manager-add-ui ui *ui-description*)
1805
1806     (window-add-accel-group window (ui-manager-accel-group ui))
1807
1808     (make-instance 'v-box
1809      :parent window
1810      :child (list
1811              (ui-manager-get-widget ui "/MenuBar")
1812              :expand nil :fill nil)
1813      :child (list
1814              (ui-manager-get-widget ui "/ToolBar")
1815              :expand nil :fill nil)
1816      :child (make-instance 'label
1817              :label "Type <alt> to start"
1818              :xalign 0.5 :yalign 0.5
1819              :width-request 200 :height-request 200))))
1820
1821
1822
1823 ;;; Main window
1824
1825 (defun create-main-window ()
1826 ;;   (rc-parse "clg:examples;testgtkrc2")
1827 ;;   (rc-parse "clg:examples;testgtkrc")
1828
1829   (let* ((button-specs
1830           '(("button box" create-button-box)
1831             ("buttons" create-buttons)
1832             ("calendar" create-calendar)
1833             ("check buttons" create-check-buttons)
1834             ("color selection" create-color-selection)
1835             ("cursors" create-cursors)
1836             ("dialog" create-dialog)
1837 ;; ;        ("dnd")
1838             ("entry" create-entry)
1839 ;;          ("event watcher")
1840             ("enxpander" create-expander)
1841             ("file chooser" create-file-chooser)
1842             ("font selection" create-font-selection)
1843             ("handle box" create-handle-box)
1844 #+gtk2.6    ("icon view" create-icon-view)
1845             ("image" create-image)
1846             ("labels" create-labels)
1847             ("layout" create-layout)
1848             ("list" create-list)
1849             ("menus" create-menus)
1850 ;;          ("modal window")
1851             ("notebook" create-notebook)
1852             ("panes" create-panes)
1853             ("progress bar" create-progress-bar)
1854             ("radio buttons" create-radio-buttons)
1855             ("range controls" create-range-controls)
1856 ;;          ("rc file")
1857             ("reparent" create-reparent)
1858             ("rulers" create-rulers)
1859 ;;          ("saved position")
1860             ("scrolled windows" create-scrolled-windows)
1861             ("size group" create-size-group)
1862             ("shapes" create-shapes)
1863             ("spinbutton" create-spins)
1864             ("statusbar" create-statusbar)
1865             ("test idle" create-idle-test)
1866 ;;          ("test mainloop")
1867 ;;          ("test scrolling")
1868 ;;          ("test selection")
1869             ("test timeout" create-timeout-test)
1870             ("text" create-text)
1871             ("toggle buttons" create-toggle-buttons)
1872             ("toolbar" create-toolbar-window)
1873             ("tooltips" create-tooltips)
1874 ;;          ("tree" #|create-tree|#)
1875             ("UI manager" create-ui-manager)
1876 ))
1877         (main-window (make-instance 'window
1878                       :title "testgtk.lisp" :name "main_window"
1879                       :default-width 200 :default-height 400
1880                       :allow-grow t :allow-shrink nil))
1881         (scrolled-window (make-instance 'scrolled-window
1882                           :hscrollbar-policy :automatic
1883                           :vscrollbar-policy :automatic
1884                           :border-width 10))
1885         (close-button (make-instance 'button
1886                        :label "close" :can-default t
1887                        :signal (list 'clicked #'widget-destroy
1888                                      :object main-window))))
1889
1890     (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1891       (setf
1892        (window-icon main-window)
1893        (gdk:pixbuf-add-alpha icon t 254 254 252)))
1894
1895     ;; Main box
1896     (make-instance 'v-box
1897      :parent main-window
1898      :child-args '(:expand nil)
1899      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1900      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1901      :child (list (make-instance 'label
1902                    :label #-cmu(format nil "~A (~A)"
1903                                 (lisp-implementation-type)
1904                                 (lisp-implementation-version))
1905                           ;; The version string in CMUCL is far too long
1906                           #+cmu(lisp-implementation-type))
1907                   :fill nil)
1908      :child (list scrolled-window :expand t)
1909      :child (make-instance 'h-separator)
1910      :child (make-instance 'v-box
1911              :homogeneous nil :spacing 10 :border-width 10
1912              :child close-button))
1913
1914     (let ((content-box
1915            (make-instance 'v-box
1916             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1917             :children (mapcar #'(lambda (spec)
1918                                   (apply #'create-button spec))
1919                               button-specs))))
1920       (scrolled-window-add-with-viewport scrolled-window content-box))
1921
1922     (widget-grab-focus close-button)
1923     (widget-show-all main-window)
1924     main-window))
1925
1926 (clg-init)
1927 (create-main-window)