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.26 2005-04-17 21:52:17 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 ;;; Handle box
 484
 485 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
 486   (make-instance 'v-box
 487    :parent window
 488    :child (create-label "Above")
 489    :child (make-instance 'h-separator)
 490    :child (make-instance 'h-box
 491            :spacing 10
 492            :child (list
 493                    (make-instance 'handle-box
 494                     :child (create-toolbar window)
 495                     :signal (list 'child-attached
 496                              #'(lambda (child)
 497                                  (format t "~A attached~%" child)))
 498                     :signal (list 'child-detached
 499                              #'(lambda (child)
 500                                  (format t "~A detached~%" child))))
 501                    :expand nil :fill :nil))
 502    :child (make-instance 'h-separator)
 503    :child (create-label "Below")))
 504
 505
 506 ;;; Icon View
 507
 508 #+gtk2.6
 509 (let ((file-pixbuf nil)
 510       (folder-pixbuf nil))
 511   (defun load-pixbufs ()
 512     (unless file-pixbuf
 513       (handler-case
 514           (setf
 515            file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
 516            folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
 517         (glib:glib-error (condition)
 518           (make-instance 'message-dialog
 519            :message-type :error :visible t
 520            :text "<b>Failed to load an image</b>"
 521            :secondary-text (glib:gerror-message condition)
 522            :signal (list :close #'widget-destroy :object t))
 523           (return-from load-pixbufs nil))))
 524     t)
 525
 526   (defun fill-store (store directory)
 527     (list-store-clear store)
 528     (let ((dir #+cmu(unix:open-dir directory)
 529                #+sbcl(sb-posix:opendir directory)))
 530       (unwind-protect
 531           (loop
 532            as filename = #+cmu(unix:read-dir dir)
 533                          #+sbcl(let ((dirent (sb-posix:readdir dir)))
 534                                  (unless (sb-grovel::foreign-nullp dirent)
 535                                    (sb-posix:dirent-name dirent)))
 536            while filename
 537            unless (or (equal filename ".") (equal filename ".."))
 538            do (let* ((pathname (format nil "~A~A" directory filename))
 539                      (directory-p
 540                       #+cmu(eq (unix:unix-file-kind pathname) :directory)
 541                       #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
 542                 (list-store-append store
 543                  (vector
 544                   filename
 545                   (if directory-p folder-pixbuf file-pixbuf)
 546                   directory-p))))
 547         #+cmu(unix:close-dir dir)
 548         #+sbcl(sb-posix:closedir dir))))
 549
 550   (defun sort-func (store a b)
 551     (let ((a-dir-p (tree-model-value store a 'directory-p))
 552           (b-dir-p (tree-model-value store b 'directory-p))
 553           (a-name (tree-model-value store a 'filename))
 554           (b-name (tree-model-value store b 'filename)))
 555       (cond
 556        ((and a-dir-p (not b-dir-p)) :before)
 557        ((and (not a-dir-p) b-dir-p) :after)
 558        ((string< a-name b-name) :before)
 559        ((string> a-name b-name) :after)
 560        (t :equal))))
 561
 562   (defun parent-dir (dir)
 563     (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
 564       (subseq dir 0 end)))
 565
 566   (define-toplevel create-icon-view (window "Icon View demo"
 567                                      :default-width 650
 568                                      :default-height 400)
 569     (if (not (load-pixbufs))
 570         (widget-destroy window)
 571       (let* ((directory "/")
 572              (store (make-instance 'list-store
 573                      :column-types '(string gdk:pixbuf boolean)
 574                      :column-names '(filename pixbuf directory-p)))
 575              (icon-view (make-instance 'icon-view
 576                          :model store :selection-mode :multiple
 577                          :text-column 'filename :pixbuf-column 'pixbuf))
 578              (up (make-instance 'tool-button
 579                   :stock "gtk-go-up" :is-important t :sensitive nil))
 580              (home (make-instance 'tool-button
 581                     :stock  "gtk-home" :is-important t)))
 582         (tree-sortable-set-sort-func store :default #'sort-func)
 583         (tree-sortable-set-sort-column store :default :ascending)
 584         (fill-store store directory)
 585
 586         (signal-connect icon-view 'item-activated
 587          #'(lambda (path)
 588              (when (tree-model-value store path 'directory-p)
 589                (setq directory
 590                      (concatenate 'string directory (tree-model-value store path 'filename) "/"))
 591                (fill-store store directory)
 592                (setf (widget-sensitive-p up) t))))
 593
 594         (signal-connect up 'clicked
 595          #'(lambda ()
 596              (unless (string= directory "/")
 597                (setq directory (parent-dir directory))
 598                (fill-store store directory)
 599                (setf
 600                 (widget-sensitive-p home)
 601                 (not (string= directory (namestring (truename #p"clg:")))))
 602                (setf (widget-sensitive-p up) (not (string= directory "/"))))))
 603
 604         (signal-connect home 'clicked
 605          #'(lambda ()
 606              (setq directory (namestring (truename #p"clg:")))
 607              (fill-store store directory)
 608              (setf (widget-sensitive-p up) t)
 609              (setf (widget-sensitive-p home) nil)))
 610
 611         (make-instance 'v-box
 612          :parent window
 613          :child (list
 614                  (make-instance 'toolbar :child up :child home)
 615                  :fill nil :expand nil)
 616          :child (make-instance 'scrolled-window
 617                  :shadow-type :etched-in :policy :automatic
 618                  :child icon-view))))))
 619
 620
 621 ;;; Image
 622
 623 (define-toplevel create-image (window "Image" :resizable nil)
 624   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 625
 626
 627 ;;; Labels
 628
 629 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 630   (flet ((create-label-in-frame (frame-label label-text &rest args)
 631            (list
 632             (make-instance 'frame
 633              :label frame-label
 634              :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
 635             :fill nil :expand nil)))
 636     (make-instance 'h-box
 637      :spacing 5 :parent window
 638      :child-args '(:fill nil :expand nil)
 639      :child (make-instance 'v-box
 640              :spacing 5
 641              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 642              :child (create-label-in-frame "Multi-line Label"
 643 "This is a Multi-line label.
 644 Second line
 645 Third line")
 646              :child (create-label-in-frame "Left Justified Label"
 647 "This is a Left-Justified
 648 Multi-line.
 649 Third line"
 650                       :justify :left)
 651              :child (create-label-in-frame "Right Justified Label"
 652 "This is a Right-Justified
 653 Multi-line.
 654 Third line"
 655                      :justify :right))
 656      :child (make-instance 'v-box
 657              :spacing 5
 658              :child (create-label-in-frame "Line wrapped label"
 659 "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.
 660      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 661                       :wrap t)
 662
 663              :child (create-label-in-frame "Filled, wrapped label"
 664 "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.
 665     This is a new paragraph.
 666     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 667                       :justify :fill :wrap t)
 668
 669              :child (create-label-in-frame "Underlined label"
 670 (#+cmu glib:latin1-to-unicode #+sbcl identity
 671 "This label is underlined!
 672 This one is underlined (æøåÆØÅ) in quite a funky fashion")
 673                       :justify :left
 674                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 675
 676
 677 ;;; Layout
 678
 679 (defun layout-expose (layout event)
 680   (when (eq (gdk:event-window event) (layout-bin-window layout))
 681     (with-slots (gdk:x gdk:y gdk:width gdk:height) event
 682       (let ((imin (truncate gdk:x 10))
 683             (imax (truncate (+ gdk:x gdk:width 9) 10))
 684             (jmin (truncate gdk:y 10))
 685             (jmax (truncate (+ gdk:y gdk:height 9) 10)))
 686
 687         (let ((window (layout-bin-window layout))
 688               (gc (style-black-gc (widget-style layout))))
 689           (loop
 690            for i from imin below imax
 691            do (loop
 692                for j from jmin below jmax
 693                unless (zerop (mod (+ i j) 2))
 694                do (gdk:draw-rectangle
 695                    window gc t (* 10 i) (* 10 j)
 696                    (1+ (mod i 10)) (1+ (mod j 10)))))))))
 697   nil)
 698
 699 (define-toplevel create-layout (window "Layout" :default-width 200
 700                                                 :default-height 200)
 701   (let ((layout (make-instance 'layout
 702                  :parent (make-instance 'scrolled-window :parent window)
 703                  :width 1600 :height 128000 :events '(:exposure)
 704                  :signal (list 'expose-event #'layout-expose :object t))))
 705
 706     (with-slots (hadjustment vadjustment) layout
 707       (setf
 708        (adjustment-step-increment hadjustment) 10.0
 709        (adjustment-step-increment vadjustment) 10.0))
 710
 711     (dotimes (i 16)
 712       (dotimes (j 16)
 713         (let ((text (format nil "Button ~D, ~D" i j)))
 714           (layout-put layout
 715            (make-instance (if (not (zerop (mod (+ i j) 2)))
 716                               'button
 717                             'label)
 718                           :label text :visible t)
 719            (* j 100) (* i 100)))))
 720
 721     (loop
 722      for i from 16 below 1280
 723      do (let ((text (format nil "Button ~D, ~D" i 0)))
 724           (layout-put layout
 725            (make-instance (if (not (zerop (mod i 2)))
 726                               'button
 727                             'label)
 728                           :label text :visible t)
 729            0 (* i 100))))))
 730
 731
 732
 733 ;;; List
 734
 735 (define-simple-dialog create-list (dialog "List" :default-height 400)
 736   (let* ((store (make-instance 'list-store
 737                  :column-types '(string integer boolean)
 738                  :column-names '(:foo :bar :baz)
 739                  :initial-content '(#("First" 12321 nil)
 740                                     (:foo "Yeah" :baz t))))
 741          (tree (make-instance 'tree-view :model store)))
 742
 743     (loop
 744      with iter = (make-instance 'tree-iter)
 745      for i from 1 to 1000
 746      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 747
 748     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 749           (cell (make-instance 'cell-renderer-text)))
 750       (cell-layout-pack column cell :expand t)
 751       (cell-layout-add-attribute column cell 'text (column-index store :foo))
 752       (tree-view-append-column tree column))
 753
 754     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 755           (cell (make-instance 'cell-renderer-text :background "orange")))
 756       (cell-layout-pack column cell :expand t)
 757       (cell-layout-add-attribute column cell 'text (column-index store :bar))
 758       (tree-view-append-column tree column))
 759
 760     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 761           (cell (make-instance 'cell-renderer-text)))
 762       (cell-layout-pack column cell :expand t)
 763       (cell-layout-add-attribute column cell 'text (column-index store :baz))
 764       (tree-view-append-column tree column))
 765
 766     (make-instance 'v-box
 767      :parent dialog :border-width 10 :spacing 10
 768      :child (list
 769              (make-instance 'h-box
 770               :spacing 10
 771               :child (make-instance 'button
 772                       :label "Remove Selection"
 773                       :signal (list 'clicked
 774                                #'(lambda ()
 775                                    (let ((references
 776                                           (mapcar
 777                                            #'(lambda (path)
 778                                                (make-instance 'tree-row-reference :model store :path path))
 779                                            (tree-selection-get-selected-rows
 780                                             (tree-view-selection tree)))))
 781                                      (mapc
 782                                       #'(lambda (reference)
 783                                           (list-store-remove store reference))
 784                                       references))))))
 785              :expand nil)
 786      :child (list
 787              (make-instance 'h-box
 788               :spacing 10
 789               :child (make-instance 'check-button
 790                       :label "Show Headers" :active t
 791                       :signal (list 'toggled
 792                                #'(lambda (button)
 793                                    (setf
 794                                     (tree-view-headers-visible-p tree)
 795                                     (toggle-button-active-p button)))
 796                                :object t))
 797               :child (make-instance 'check-button
 798                       :label "Reorderable" :active nil
 799                       :signal (list 'toggled
 800                                #'(lambda (button)
 801                                    (setf
 802                                     (tree-view-reorderable-p tree)
 803                                     (toggle-button-active-p button)))
 804                                :object t))
 805               :child (list
 806                       (make-instance 'h-box
 807                        :child (make-instance 'label :label "Selection Mode: ")
 808                        :child (make-instance 'combo-box
 809                                :content '("Single" "Browse" "Multiple")
 810                                :active 0
 811                                :signal (list 'changed
 812                                         #'(lambda (combo-box)
 813                                             (setf
 814                                              (tree-selection-mode
 815                                               (tree-view-selection tree))
 816                                              (svref
 817                                               #(:single :browse :multiple)
 818                                               (combo-box-active combo-box))))
 819                                         :object t)))
 820                       :expand nil))
 821              :expand nil)
 822      :child (make-instance 'scrolled-window
 823             :child tree :hscrollbar-policy :automatic))))
 824
 825
 826 ;; Menus
 827
 828 (defun create-menu (depth tearoff)
 829   (unless (zerop depth)
 830     (let ((menu (make-instance 'menu)))
 831       (when tearoff
 832         (let ((menu-item (make-instance 'tearoff-menu-item)))
 833           (menu-shell-append menu menu-item)))
 834       (let ((group nil))
 835         (dotimes (i 5)
 836           (let ((menu-item
 837                  (make-instance 'radio-menu-item
 838                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 839             (if group
 840                 (add-to-radio-group menu-item group)
 841               (setq group menu-item))
 842             (unless (zerop (mod depth 2))
 843               (setf (check-menu-item-active-p menu-item) t))
 844             (menu-shell-append menu menu-item)
 845             (when (= i 3)
 846               (setf (widget-sensitive-p menu-item) nil))
 847             (let ((submenu (create-menu (1- depth) t)))
 848               (when submenu
 849                 (setf (menu-item-submenu menu-item) submenu))))))
 850       menu)))
 851
 852
 853 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 854   (let* ((main (make-instance 'v-box :parent dialog))
 855 ;        (accel-group (make-instance 'accel-group))
 856          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 857 ;    (window-add-accel-group dialog accel-group)
 858
 859     (let ((menu-item (make-instance 'menu-item
 860                       :label (format nil "test~%line2"))))
 861       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 862       (menu-shell-append menubar menu-item))
 863
 864     (let ((menu-item (make-instance 'menu-item :label "foo")))
 865       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 866       (menu-shell-append menubar menu-item))
 867
 868     (let ((menu-item (make-instance 'menu-item :label "bar")))
 869       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 870       (setf (menu-item-right-justified-p menu-item) t)
 871       (menu-shell-append menubar menu-item))
 872
 873     (make-instance 'v-box
 874      :spacing 10 :border-width 10 :parent main
 875      :child (make-instance 'combo-box
 876              :active 3
 877              :content (loop
 878                        for i from 1 to 5
 879                        collect (format nil "Item ~D" i))))
 880
 881     (widget-show-all main)))
 882
 883
 884 ;;; Notebook
 885
 886 (defun create-notebook-page (notebook page-num book-closed)
 887   (let* ((title (format nil "Page ~D" page-num))
 888          (page (make-instance 'frame :label title :border-width 10))
 889          (v-box (make-instance 'v-box
 890                  :homogeneous t :border-width 10 :parent page)))
 891
 892     (make-instance 'h-box
 893      :parent (list v-box :fill nil :padding 5) :homogeneous t
 894      :child-args '(:padding 5)
 895      :child (make-instance 'check-button
 896              :label "Fill Tab" :active t
 897              :signal (list 'toggled
 898                            #'(lambda (button)
 899                                (setf
 900                                 (notebook-child-tab-fill-p page)
 901                                 (toggle-button-active-p button)))
 902                            :object t))
 903      :child (make-instance 'check-button
 904              :label "Expand Tab"
 905              :signal (list 'toggled
 906                            #'(lambda (button)
 907                                (setf
 908                                 (notebook-child-tab-expand-p page)
 909                                 (toggle-button-active-p button)))
 910                            :object t))
 911      :child (make-instance 'check-button
 912              :label "Pack end"
 913              :signal (list 'toggled
 914                            #'(lambda (button)
 915                                (setf
 916                                 (notebook-child-tab-pack page)
 917                                 (if (toggle-button-active-p button)
 918                                     :end
 919                                   :start)))
 920                            :object t))
 921      :child (make-instance 'button
 922              :label "Hide page"
 923              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 924
 925     (let ((label-box (make-instance 'h-box
 926                       :show-children t
 927                       :child-args '(:expand nil)
 928                       :child (make-instance 'image :pixbuf book-closed)
 929                       :child (make-instance 'label :label title)))
 930           (menu-box (make-instance 'h-box
 931                      :show-children t
 932                      :child-args '(:expand nil)
 933                      :child (make-instance 'image :pixbuf book-closed)
 934                      :child (make-instance 'label :label title))))
 935
 936       (widget-show-all page)
 937       (notebook-append notebook page label-box menu-box))))
 938
 939
 940 (define-simple-dialog create-notebook (dialog "Notebook")
 941   (let ((main (make-instance 'v-box :parent dialog)))
 942     (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
 943           (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
 944           (notebook (make-instance 'notebook
 945                      :border-width 10 :tab-pos :top :parent main)))
 946       (flet ((set-image (page func pixbuf)
 947                (setf
 948                 (image-pixbuf
 949                  (first (container-children (funcall func notebook page))))
 950                 pixbuf)))
 951         (signal-connect notebook 'switch-page
 952          #'(lambda (pointer page)
 953              (declare (ignore pointer))
 954              (set-image page #'notebook-menu-label book-open)
 955              (set-image page #'notebook-tab-label book-open)
 956              (when (slot-boundp notebook 'current-page)
 957                (let ((curpage (notebook-current-page notebook)))
 958                  (set-image curpage #'notebook-menu-label book-closed)
 959                  (set-image curpage #'notebook-tab-label book-closed))))))
 960       (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 961
 962       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 963
 964       (make-instance 'h-box
 965        :spacing 5 :border-width 10
 966        :parent (list main :expand nil)
 967        :child-args '(:fill nil)
 968        :child (make-instance 'check-button
 969                :label "Popup menu"
 970                :signal (list 'clicked
 971                         #'(lambda (button)
 972                             (if (toggle-button-active-p button)
 973                                 (notebook-popup-enable notebook)
 974                                 (notebook-popup-disable notebook)))
 975                         :object t))
 976        :child (make-instance 'check-button
 977                :label "Homogeneous tabs"
 978                :signal (list 'clicked
 979                         #'(lambda (button)
 980                             (setf
 981                              (notebook-homogeneous-p notebook)
 982                              (toggle-button-active-p button)))
 983                         :object t)))
 984
 985       (make-instance 'h-box
 986        :spacing 5 :border-width 10
 987        :parent (list main :expand nil)
 988        :child-args '(:expand nil)
 989        :child (make-instance 'label :label "Notebook Style: ")
 990        :child (let ((scrollable-p nil))
 991                 (make-instance 'combo-box
 992                  :content '("Standard" "No tabs" "Scrollable") :active 0
 993                  :signal (list 'changed
 994                           #'(lambda (combo-box)
 995                               (case (combo-box-active combo-box)
 996                                 (0
 997                                  (setf (notebook-show-tabs-p notebook) t)
 998                                  (when scrollable-p
 999                                    (setq scrollable-p nil)
1000                                    (setf (notebook-scrollable-p notebook) nil)
1001                                    (loop repeat 10
1002                                     do (notebook-remove-page notebook 5))))
1003                                 (1
1004                                  (setf (notebook-show-tabs-p notebook) nil)
1005                                  (when scrollable-p
1006                                    (setq scrollable-p nil)
1007                                    (setf (notebook-scrollable-p notebook) nil)
1008                                    (loop repeat 10
1009                                      do (notebook-remove-page notebook 5))))
1010                                 (2
1011                                  (unless scrollable-p
1012                                    (setq scrollable-p t)
1013                                    (setf (notebook-show-tabs-p notebook) t)
1014                                    (setf (notebook-scrollable-p notebook) t)
1015                                    (loop for i from 6 to 15
1016                                     do (create-notebook-page notebook i book-closed))))))
1017                           :object t)))
1018        :child (make-instance 'button
1019                :label "Show all Pages"
1020                :signal (list 'clicked
1021                         #'(lambda ()
1022                             (map-container nil #'widget-show notebook)))))
1023
1024       (make-instance 'h-box
1025        :spacing 5 :border-width 10
1026        :parent (list main :expand nil)
1027        :child (make-instance 'button
1028                :label "prev"
1029                :signal (list 'clicked #'notebook-prev-page :object notebook))
1030        :child (make-instance 'button
1031                :label "next"
1032                :signal (list 'clicked #'notebook-next-page :object notebook))
1033        :child (make-instance 'button
1034                :label "rotate"
1035                :signal (let ((tab-pos 0))
1036                          (list 'clicked
1037                           #'(lambda ()
1038                               (setq tab-pos (mod (1+ tab-pos) 4))
1039                               (setf
1040                                (notebook-tab-pos notebook)
1041                                (svref #(:top :right :bottom :left) tab-pos))))))))
1042     (widget-show-all main)))
1043
1044
1045 ;;; Panes
1046
1047 (defun toggle-resize (child)
1048   (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1049
1050 (defun toggle-shrink (child)
1051   (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1052
1053 (defun create-pane-options (paned frame-label label1 label2)
1054   (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1055     (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1056     (let ((check-button (make-instance 'check-button :label "Resize")))
1057       (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1058       (signal-connect check-button 'toggled
1059        #'toggle-resize :object (paned-child1 paned)))
1060     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1061       (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1062       (signal-connect check-button 'toggled
1063        #'toggle-shrink :object (paned-child1 paned)))
1064
1065     (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1066     (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1067       (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1068       (signal-connect check-button 'toggled
1069        #'toggle-resize :object (paned-child2 paned)))
1070     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1071       (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1072       (signal-connect check-button 'toggled
1073        #'toggle-shrink :object (paned-child2 paned)))
1074     (make-instance 'frame :label frame-label :border-width 4 :child table)))
1075
1076 (define-toplevel create-panes (window "Panes")
1077   (let* ((hpaned (make-instance 'h-paned
1078                   :child1 (make-instance 'frame
1079                            :width-request 60 :height-request 60
1080                            :shadow-type :in
1081                            :child (make-instance 'button :label "Hi there"))
1082                   :child2 (make-instance 'frame
1083                            :width-request 80 :height-request 60
1084                            :shadow-type :in)))
1085          (vpaned (make-instance 'v-paned
1086                   :border-width 5
1087                   :child1 hpaned
1088                   :child2 (make-instance 'frame
1089                            :width-request 80 :height-request 60
1090                            :shadow-type :in))))
1091
1092     (make-instance 'v-box
1093      :parent window
1094      :child-args '(:expand nil)
1095      :child (list vpaned :expand t)
1096      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1097      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1098
1099
1100 ;;; Progress bar
1101
1102 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1103   (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1104          (activity-mode-button (make-instance 'check-button
1105                                 :label "Activity mode"))
1106          (timer (timeout-add 100
1107                  #'(lambda ()
1108                      (if (toggle-button-active-p activity-mode-button)
1109                          (progress-bar-pulse progress)
1110                        (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1111                          (setf
1112                           (progress-bar-fraction progress)
1113                           (if (> fract 1.0)
1114                               0.0
1115                             fract))))
1116                      t))))
1117
1118     (make-instance 'v-box
1119      :parent dialog :border-width 10 :spacing 10
1120      :child progress
1121      :child activity-mode-button)
1122
1123     (signal-connect dialog 'destroy
1124      #'(lambda () (when timer (timeout-remove timer))))))
1125
1126
1127 ;;; Radio buttons
1128
1129 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1130   (make-instance 'v-box
1131    :parent dialog :border-width 10 :spacing 10
1132    :children (make-radio-group 'radio-button
1133               '((:label "button1") (:label "button2") (:label "button3"))
1134               nil)))
1135
1136
1137 ;;; Rangle controls
1138
1139 (define-simple-dialog create-range-controls (dialog "Range controls")
1140   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1141     (make-instance 'v-box
1142      :parent dialog :border-width 10 :spacing 10
1143      :child (make-instance 'h-scale
1144              :width-request 150 :adjustment adjustment :inverted t
1145              :update-policy :delayed :digits 1 :draw-value t)
1146      :child (make-instance 'h-scrollbar
1147              :adjustment adjustment :update-policy :continuous))))
1148
1149
1150 ;;; Reparent test
1151
1152 (define-simple-dialog create-reparent (dialog "Reparent")
1153   (let ((main (make-instance 'h-box
1154                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1155         (label (make-instance 'label :label "Hello World")))
1156
1157     (flet ((create-frame (title)
1158              (let* ((frame (make-instance 'frame :label title :parent main))
1159                     (box (make-instance 'v-box
1160                           :spacing 5 :border-width 5 :parent frame))
1161                     (button (make-instance 'button
1162                              :label "switch" :parent (list box :expand nil))))
1163                (signal-connect button 'clicked
1164                 #'(lambda ()
1165                     (widget-reparent label box)))
1166                box)))
1167
1168       (box-pack-start (create-frame "Frame 1") label nil t 0)
1169       (create-frame "Frame 2"))
1170     (widget-show-all main)))
1171
1172
1173 ;;; Rulers
1174
1175 (define-toplevel create-rulers (window "Rulers"
1176                                 :default-width 300 :default-height 300
1177                                 :events '(:pointer-motion :pointer-motion-hint))
1178   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1179         (h-ruler (make-instance 'h-ruler
1180                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1181                   :position 0.0d0 :max-size 20.0d0))
1182         (v-ruler (make-instance 'v-ruler
1183                   :lower 5.0d0 :upper 15.0d0
1184                   :position 0.0d0 :max-size 20.0d0)))
1185     (signal-connect window 'motion-notify-event
1186      #'(lambda (event)
1187          (widget-event h-ruler event)
1188          (widget-event v-ruler event)))
1189     (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1190     (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1191
1192
1193 ;;; Scrolled window
1194
1195 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1196                                                       :default-width 300
1197                                                       :default-height 300)
1198   (let* ((scrolled-window
1199           (make-instance 'scrolled-window
1200            :parent dialog :border-width 10
1201            :vscrollbar-policy :automatic
1202            :hscrollbar-policy :automatic))
1203          (table
1204           (make-instance 'table
1205            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1206            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1207            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1208
1209       (scrolled-window-add-with-viewport scrolled-window table)
1210       (dotimes (i 20)
1211         (dotimes (j 20)
1212           (let ((button
1213                  (make-instance 'toggle-button
1214                   :label (format nil "button (~D,~D)~%" i j))))
1215             (table-attach table button i (1+ i) j (1+ j)))))
1216       (widget-show-all scrolled-window)))
1217
1218
1219 ;;; Size group
1220
1221 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1222   (let ((size-group (make-instance 'size-group)))
1223     (flet ((create-frame (label rows)
1224              (let ((table (make-instance 'table
1225                            :n-rows (length rows) :n-columns 2 :homogeneous nil
1226                            :row-spacing 5 :column-spacing 10 :border-width 5)))
1227                (loop
1228                 for row in rows
1229                 for i from 0
1230                 do (table-attach table
1231                     (create-label (first row) :xalign 0 :yalign 1)
1232                     0 1 i (1+ i) :x-options '(:expand :fill))
1233                    (let ((combo (make-instance 'combo-box
1234                                  :content (rest row) :active 0)))
1235                      (size-group-add-widget size-group combo)
1236                      (table-attach table combo 1 2 i (1+ i))))
1237                (make-instance 'frame :label label :child table))))
1238
1239       (make-instance 'v-box
1240        :parent dialog :border-width 5 :spacing 5
1241        :child (create-frame "Color Options"
1242                '(("Foreground" "Red" "Green" "Blue")
1243                  ("Background" "Red" "Green" "Blue")))
1244        :child (create-frame "Line Options"
1245                '(("Dashing" "Solid" "Dashed" "Dotted")
1246                  ("Line ends" "Square" "Round" "Arrow")))
1247        :child (create-check-button "Enable grouping"
1248                #'(lambda (active)
1249                    (setf
1250                     (size-group-mode size-group)
1251                     (if active :horizontal :none)))
1252                t)))))
1253
1254
1255 ;;; Shapes
1256
1257 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1258   (let ((window
1259          (make-instance 'window
1260           :type type :default-width 100 :default-height 100
1261           :events '(:button-motion :pointer-motion-hint :button-press)
1262           :signal (list 'destroy destroy))))
1263
1264     (widget-realize window)
1265     (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1266       (let ((fixed (make-instance 'fixed :parent window)))
1267         (fixed-put fixed (create-image-widget source mask) px py))
1268       (widget-shape-combine-mask window mask px py))
1269
1270     (let ((x-offset 0)
1271           (y-offset 0))
1272       (declare (fixnum x-offset y-offset))
1273       (signal-connect window 'button-press-event
1274        #'(lambda (event)
1275            (when (typep event 'gdk:button-press-event)
1276              (setq x-offset (truncate (gdk:event-x event)))
1277              (setq y-offset (truncate (gdk:event-y event)))
1278              (grab-add window)
1279              (gdk:pointer-grab (widget-window window)
1280               :events '(:button-release :button-motion :pointer-motion-hint)
1281               :owner-events t :time event))))
1282
1283       (signal-connect window 'button-release-event
1284        #'(lambda (event)
1285            (grab-remove window)
1286            (gdk:pointer-ungrab event)))
1287
1288       (signal-connect window 'motion-notify-event
1289        #'(lambda (event)
1290            (declare (ignore event))
1291            (multiple-value-bind (win xp yp mask)
1292                (gdk:window-get-pointer root-window)
1293              (declare (ignore mask win) (fixnum xp yp))
1294              (window-move window (- xp x-offset) (- yp y-offset))))))
1295
1296     (window-move window x y)
1297     (widget-show-all window)
1298     window))
1299
1300
1301 (let ((modeller nil)
1302       (sheets nil)
1303       (rings nil))
1304   (defun create-shapes ()
1305     (let ((root-window (gdk:get-root-window)))
1306       (if (not modeller)
1307           (setq
1308            modeller
1309            (create-shape-icon
1310             "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1311             #'(lambda () (setq modeller nil))))
1312         (widget-destroy modeller))
1313
1314       (if (not sheets)
1315           (setq
1316            sheets
1317            (create-shape-icon
1318             "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1319             #'(lambda () (setq sheets nil))))
1320         (widget-destroy sheets))
1321
1322       (if (not rings)
1323           (setq
1324            rings
1325            (create-shape-icon
1326             "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1327             #'(lambda () (setq rings nil))))
1328         (widget-destroy rings)))))
1329
1330
1331
1332 ;;; Spin buttons
1333
1334 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1335   (let ((main (make-instance 'v-box
1336                :spacing 5 :border-width 10 :parent dialog)))
1337
1338     (flet ((create-date-spinner (label adjustment shadow-type)
1339              (declare (ignore shadow-type))
1340              (make-instance 'v-box
1341               :child-args '(:expand nil)
1342               :child (make-instance 'label
1343                       :label label :xalign 0.0 :yalign 0.5)
1344               :child (make-instance 'spin-button
1345                       :adjustment adjustment :wrap t))))
1346       (multiple-value-bind (sec min hour date month year day daylight-p zone)
1347           (get-decoded-time)
1348         (declare (ignore sec min hour day daylight-p zone))
1349         (make-instance 'frame
1350          :label "Not accelerated" :parent main
1351          :child (make-instance 'h-box
1352                  :border-width 10
1353                  :child-args '(:padding 5)
1354                  :child (create-date-spinner "Day : "
1355                          (adjustment-new date 1 31 1 5 0) :out)
1356                  :child (create-date-spinner "Month : "
1357                          (adjustment-new month 1 12 1 5 0) :etched-in)
1358                  :child (create-date-spinner "Year : "
1359                          (adjustment-new year 0 2100 1 100 0) :in)))))
1360
1361     (let ((spinner1 (make-instance 'spin-button
1362                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1363                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1364           (spinner2 (make-instance 'spin-button
1365                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1366                      :climb-rate 1.0 :wrap t))
1367           (value-label (make-instance 'label :label "0")))
1368       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1369        #'(lambda ()
1370            (setf
1371             (spin-button-digits spinner1)
1372             (floor (spin-button-value spinner2)))))
1373
1374       (make-instance 'frame
1375        :label "Accelerated" :parent main
1376        :child (make-instance 'v-box
1377                :border-width 5
1378                :child (list
1379                        (make-instance 'h-box
1380                         :child-args '(:padding 5)
1381                         :child (make-instance 'v-box
1382                                 :child (make-instance 'label
1383                                         :label "Value :"
1384                                         :xalign 0.0 :yalign 0.5)
1385                                 :child spinner1)
1386                         :child (make-instance 'v-box
1387                                 :child (make-instance 'label
1388                                         :label "Digits :"
1389                                         :xalign 0.0 :yalign 0.5)
1390                                 :child spinner2))
1391                        :expand nil :padding 5)
1392                :child (make-instance 'check-button
1393                        :label "Snap to 0.5-ticks" :active t
1394                        :signal (list 'clicked
1395                                 #'(lambda (button)
1396                                     (setf
1397                                      (spin-button-snap-to-ticks-p spinner1)
1398                                      (toggle-button-active-p button)))
1399                                 :object t))
1400                :child (make-instance 'check-button
1401                        :label "Numeric only input mode" :active t
1402                        :signal (list 'clicked
1403                                 #'(lambda (button)
1404                                     (setf
1405                                      (spin-button-numeric-p spinner1)
1406                                      (toggle-button-active-p button)))
1407                                 :object t))
1408                :child value-label
1409                :child (list
1410                        (make-instance 'h-box
1411                         :child-args '(:padding 5)
1412                         :child (make-instance 'button
1413                                 :label "Value as Int"
1414                                 :signal (list 'clicked
1415                                          #'(lambda ()
1416                                              (setf
1417                                               (label-label value-label)
1418                                               (format nil "~D"
1419                                                (spin-button-value-as-int
1420                                                 spinner1))))))
1421                         :child (make-instance 'button
1422                                 :label "Value as Float"
1423                                 :signal (list 'clicked
1424                                          #'(lambda ()
1425                                              (setf
1426                                               (label-label value-label)
1427                                               (format nil
1428                                                (format nil "~~,~DF"
1429                                                 (spin-button-digits spinner1))
1430                                                (spin-button-value spinner1)))))))
1431                        :padding 5 :expand nil))))
1432     (widget-show-all main)))
1433
1434
1435 ;;; Statusbar
1436
1437 (define-toplevel create-statusbar (window "Statusbar")
1438   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1439         (close-button (create-button '("close" :can-default t)
1440                        #'widget-destroy :object window))
1441         (counter 0))
1442
1443     (signal-connect statusbar 'text-popped
1444      #'(lambda (context-id text)
1445          (declare (ignore context-id))
1446          (format nil "Popped: ~A~%" text)))
1447
1448     (make-instance 'v-box
1449      :parent window
1450      :child (make-instance 'v-box
1451              :border-width 10 :spacing 10
1452              :child (create-button "push something"
1453                      #'(lambda ()
1454                          (statusbar-push statusbar 1
1455                           (format nil "something ~D" (incf counter)))))
1456              :child (create-button "pop"
1457                      #'(lambda ()
1458                          (statusbar-pop statusbar 1)))
1459              :child (create-button "steal #4"
1460                      #'(lambda ()
1461                          (statusbar-remove statusbar 1 4)))
1462              :child (create-button "dump stack")
1463              :child (create-button "test contexts"))
1464      :child (list (make-instance 'h-separator) :expand nil)
1465      :child (list
1466              (make-instance 'v-box :border-width 10 :child close-button)
1467              :expand nil)
1468      :child (list statusbar :expand nil))
1469
1470     (widget-grab-focus close-button)))
1471
1472
1473 ;;; Idle test
1474
1475 (define-simple-dialog create-idle-test (dialog "Idle Test")
1476   (let ((label (make-instance 'label
1477                 :label "count: 0" :xpad 10 :ypad 10))
1478         (idle nil)
1479         (count 0))
1480     (signal-connect dialog 'destroy
1481      #'(lambda () (when idle (idle-remove idle))))
1482
1483     (make-instance 'v-box
1484      :parent dialog :border-width 10 :spacing 10
1485      :child label
1486      :child (make-instance 'frame
1487              :label "Label Container" :border-width 5
1488              :child(make-instance 'v-box
1489                    :children (make-radio-group 'radio-button
1490                               '((:label "Resize-Parent" :value :parent :active t)
1491                                 (:label "Resize-Queue" :value :queue)
1492                                 (:label "Resize-Immediate" :value :immediate))
1493                               #'(lambda (mode)
1494                                   (setf
1495                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1496
1497     (dialog-add-button dialog "Start"
1498      #'(lambda ()
1499          (unless idle
1500            (setq idle
1501             (idle-add
1502              #'(lambda ()
1503                  (incf count)
1504                  (setf (label-label label) (format nil "count: ~D" count))
1505                  t))))))
1506
1507     (dialog-add-button dialog "Stop"
1508      #'(lambda ()
1509          (when idle
1510            (idle-remove idle)
1511            (setq idle nil))))))
1512
1513
1514
1515 ;;; Timeout test
1516
1517 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1518   (let ((label (make-instance 'label
1519                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1520         (timer nil)
1521         (count 0))
1522     (signal-connect dialog 'destroy
1523      #'(lambda () (when timer (timeout-remove timer))))
1524
1525     (dialog-add-button dialog "Start"
1526      #'(lambda ()
1527          (unless timer
1528            (setq timer
1529             (timeout-add 100
1530              #'(lambda ()
1531                  (incf count)
1532                  (setf (label-label label) (format nil "count: ~D" count))
1533                  t))))))
1534
1535     (dialog-add-button dialog "Stop"
1536      #'(lambda ()
1537          (when timer
1538            (timeout-remove timer)
1539            (setq timer nil))))))
1540
1541
1542 ;;; Text
1543
1544 (define-simple-dialog create-text (dialog "Text" :default-width 400
1545                                                  :default-height 400)
1546   (let* ((text-view (make-instance 'text-view
1547                      :border-width 10 :visible t :wrap-mode :word))
1548          (buffer (text-view-buffer text-view))
1549          (active-tags ()))
1550
1551     (text-buffer-create-tag buffer "Bold" :weight :bold)
1552     (text-buffer-create-tag buffer "Italic" :style :italic)
1553     (text-buffer-create-tag buffer "Underline" :underline :single)
1554
1555     (flet ((create-toggle-callback (tag-name)
1556              (let ((tag (text-tag-table-lookup
1557                          (text-buffer-tag-table buffer) tag-name)))
1558                #'(lambda (active)
1559                    (unless (eq (and (find tag active-tags) t) active)
1560                      ;; user activated
1561                      (if active
1562                          (push tag active-tags)
1563                        (setq active-tags (delete tag active-tags)))
1564                      (multiple-value-bind (non-zero-p start end)
1565                          (text-buffer-get-selection-bounds buffer)
1566                        (declare (ignore non-zero-p))
1567                        (if active
1568                            (text-buffer-apply-tag buffer tag start end)
1569                          (text-buffer-remove-tag buffer tag start end))))))))
1570
1571       (let* ((actions
1572               (make-instance 'action-group
1573                :action (create-toggle-action
1574                         "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1575                         (create-toggle-callback "Bold"))
1576                :action (create-toggle-action
1577                         "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1578                         (create-toggle-callback "Italic"))
1579                :action (create-toggle-action
1580                         "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1581                         (create-toggle-callback "Underline"))))
1582              (ui (make-instance 'ui-manager)))
1583
1584         (ui-manager-insert-action-group ui actions)
1585         (ui-manager-add-ui ui
1586          '((:toolbar "ToolBar"
1587             (:toolitem "Bold")
1588             (:toolitem "Italic")
1589             (:toolitem "Underline"))))
1590
1591         ;; Callback to activate/deactivate toolbar buttons when cursor
1592         ;; is moved
1593         (signal-connect buffer 'mark-set
1594          #'(lambda (location mark)
1595              (declare (ignore mark))
1596              (text-tag-table-foreach (text-buffer-tag-table buffer)
1597               #'(lambda (tag)
1598                   (let ((active
1599                          (or
1600                           (and
1601                            (text-iter-has-tag-p location tag)
1602                            (not (text-iter-begins-tag-p location tag)))
1603                           (text-iter-ends-tag-p location tag))))
1604                     (unless (eq active (and (find tag active-tags) t))
1605                       (if active
1606                           (push tag active-tags)
1607                         (setq active-tags (delete tag active-tags)))
1608                       (setf
1609                        (toggle-action-active-p
1610                         (action-group-get-action actions (text-tag-name tag)))
1611                        active)))))))
1612
1613         ;; Callback to apply active tags when a character is inserted
1614         (signal-connect buffer 'insert-text
1615          #'(lambda (iter &rest args)
1616              (declare (ignore args))
1617              (let ((before (text-buffer-get-iter-at-offset buffer
1618                             (1- (text-iter-offset iter)))))
1619                (loop
1620                 for tag in active-tags
1621                 do (text-buffer-apply-tag buffer tag before iter))))
1622          :after t)
1623
1624         (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1625         (container-add dialog text-view)))))
1626
1627
1628 ;;; Toggle buttons
1629
1630 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1631   (make-instance 'v-box
1632    :border-width 10 :spacing 10 :parent dialog
1633       :children (loop
1634               for n from 1 to 3
1635               collect (make-instance 'toggle-button
1636                        :label (format nil "Button~D" (1+ n))))))
1637
1638
1639
1640 ;;; Toolbar test
1641
1642 (defun create-toolbar (window)
1643   (make-instance 'toolbar
1644    :show-tooltips t :show-arrow nil
1645
1646    ;; Insert a stock item
1647    :child (make-instance 'tool-button
1648            :stock  "gtk-quit"
1649            :tip-text "Destroy toolbar"
1650            :tip-private "Toolbar/Quit"
1651            :signal (list 'clicked #'(lambda () (widget-destroy window))))
1652
1653    :child (make-instance 'separator-tool-item)
1654
1655    :child (make-instance 'tool-button
1656            :label "Horizontal" :stock "gtk-go-forward"
1657            :tip-text "Horizontal toolbar layout"
1658            :tip-private "Toolbar/Horizontal"
1659            :signal (list 'clicked
1660                     #'(lambda (toolbar)
1661                         (setf (toolbar-orientation toolbar) :horizontal))
1662                     :object :parent))
1663
1664    :child (make-instance 'tool-button
1665            :label "Vertical" :stock "gtk-go-down"
1666            :tip-text "Vertical toolbar layout"
1667            :tip-private "Toolbar/Vertical"
1668            :signal (list 'clicked
1669                     #'(lambda (toolbar)
1670                         (setf (toolbar-orientation toolbar) :vertical))
1671                     :object :parent))
1672
1673    :child (make-instance 'separator-tool-item)
1674
1675    :children (make-radio-group 'radio-tool-button
1676               '((:label "Icons" :stock "gtk-justify-left"
1677                  :tip-text "Only show toolbar icons"
1678                  :tip-private "Toolbar/IconsOnly"
1679                  :value :icons)
1680                 (:label "Both" :stock "gtk-justify-center"
1681                  :tip-text "Show toolbar icons and text"
1682                  :tip-private "Toolbar/Both"
1683                  :value :both :active t)
1684                 (:label "Text" :stock "gtk-justify-right"
1685                  :tip-text "Show toolbar text"
1686                  :tip-private "Toolbar/TextOnly"
1687                  :value :text))
1688               (list
1689                #'(lambda (toolbar style)
1690                    (setf (toolbar-style toolbar) style))
1691                :object :parent))
1692
1693    :child (make-instance 'separator-tool-item)
1694
1695    :child (make-instance 'tool-item
1696            :child (make-instance 'entry)
1697            :tip-text "This is an unusable GtkEntry"
1698            :tip-private "Hey don't click me!")
1699
1700    :child (make-instance 'separator-tool-item)
1701
1702    :child (make-instance 'tool-button
1703            :label "Enable" :stock "gtk-add"
1704            :tip-text "Enable tooltips"
1705            :tip-private "Toolbar/EnableTooltips"
1706            :signal (list 'clicked
1707                     #'(lambda (toolbar)
1708                         (setf (toolbar-show-tooltips-p toolbar) t))
1709                     :object :parent))
1710
1711    :child (make-instance 'tool-button
1712            :label "Disable" :stock "gtk-remove"
1713            :tip-text "Disable tooltips"
1714            :tip-private "Toolbar/DisableTooltips"
1715            :signal (list 'clicked
1716                     #'(lambda (toolbar)
1717                         (setf (toolbar-show-tooltips-p toolbar) nil))
1718                     :object :parent))
1719
1720 ;;    :child (make-instance 'separator-tool-item)
1721
1722 ;;    :child (make-instance 'tool-button
1723 ;;         :label "GTK" :icon #p"clg:examples;gtk.png"
1724 ;;         :tip-text "GTK+ Logo"
1725 ;;         :tip-private "Toolbar/GTK+")
1726    ))
1727
1728 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1729   (container-add window (create-toolbar window)))
1730
1731
1732
1733 ;;; Tooltips test
1734
1735 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1736   (let ((tooltips (make-instance 'tooltips)))
1737     (flet ((create-button (label tip-text tip-private)
1738              (let ((button (make-instance 'toggle-button :label label)))
1739                (tooltips-set-tip tooltips button tip-text tip-private)
1740                button)))
1741       (make-instance 'v-box
1742        :parent dialog :border-width 10 :spacing 10
1743        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1744        :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")))))
1745
1746
1747 ;;; UI Manager
1748
1749 (defvar *ui-description*
1750   '((:menubar "MenuBar"
1751      (:menu "FileMenu"
1752       (:menuitem "New")
1753       (:menuitem "Open")
1754       (:menuitem "Save")
1755       (:menuitem "SaveAs")
1756       :separator
1757       (:menuitem "Quit"))
1758      (:menu "PreferencesMenu"
1759        (:menu "ColorMenu"
1760         (:menuitem "Red")
1761         (:menuitem "Green")
1762         (:menuitem "Blue"))
1763        (:menu "ShapeMenu"
1764         (:menuitem "Square")
1765         (:menuitem "Rectangle")
1766         (:menuitem "Oval"))
1767        (:menuitem "Bold"))
1768      (:menu "HelpMenu"
1769       (:menuitem "About")))
1770     (:toolbar "ToolBar"
1771      (:toolitem "Open")
1772      (:toolitem "Quit")
1773      (:separator "Sep1")
1774      (:toolitem "Logo"))))
1775
1776 (define-toplevel create-ui-manager (window "UI Manager")
1777   (let ((actions
1778          (make-instance 'action-group
1779           :name "Actions"
1780           :action (create-action "FileMenu" nil "_File")
1781           :action (create-action "PreferencesMenu" nil "_Preferences")
1782           :action (create-action "ColorMenu" nil "_Color")
1783           :action (create-action "ShapeMenu" nil "_Shape")
1784           :action (create-action "HelpMenu" nil "_Help")
1785           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1786           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
1787           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1788           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1789           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
1790           :action (create-action "About" nil "_About" "<control>A" "About")
1791           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1792           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1793           :actions (create-radio-actions
1794                     '(("Red" nil "_Red" "<control>R" "Blood")
1795                       ("Green" nil "_Green" "<control>G" "Grass")
1796                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1797                     "Green")
1798           :actions (create-radio-actions
1799                     '(("Square" nil "_Square" "<control>S" "Square")
1800                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1801                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1802         (ui (make-instance 'ui-manager)))
1803
1804     (ui-manager-insert-action-group ui actions)
1805     (ui-manager-add-ui ui *ui-description*)
1806
1807     (window-add-accel-group window (ui-manager-accel-group ui))
1808
1809     (make-instance 'v-box
1810      :parent window
1811      :child (list
1812              (ui-manager-get-widget ui "/MenuBar")
1813              :expand nil :fill nil)
1814      :child (list
1815              (ui-manager-get-widget ui "/ToolBar")
1816              :expand nil :fill nil)
1817      :child (make-instance 'label
1818              :label "Type <alt> to start"
1819              :xalign 0.5 :yalign 0.5
1820              :width-request 200 :height-request 200))))
1821
1822
1823
1824 ;;; Main window
1825
1826 (defun create-main-window ()
1827 ;;   (rc-parse "clg:examples;testgtkrc2")
1828 ;;   (rc-parse "clg:examples;testgtkrc")
1829
1830   (let* ((button-specs
1831           '(("button box" create-button-box)
1832             ("buttons" create-buttons)
1833             ("calendar" create-calendar)
1834             ("check buttons" create-check-buttons)
1835             ("color selection" create-color-selection)
1836             ("cursors" create-cursors)
1837             ("dialog" create-dialog)
1838 ;; ;        ("dnd")
1839             ("entry" create-entry)
1840 ;;          ("event watcher")
1841             ("enxpander" create-expander)
1842             ("file chooser" create-file-chooser)
1843             ("font selection" create-font-selection)
1844             ("handle box" create-handle-box)
1845 #+gtk2.6    ("icon view" create-icon-view)
1846             ("image" create-image)
1847             ("labels" create-labels)
1848             ("layout" create-layout)
1849             ("list" create-list)
1850             ("menus" create-menus)
1851 ;;          ("modal window")
1852             ("notebook" create-notebook)
1853             ("panes" create-panes)
1854             ("progress bar" create-progress-bar)
1855             ("radio buttons" create-radio-buttons)
1856             ("range controls" create-range-controls)
1857 ;;          ("rc file")
1858             ("reparent" create-reparent)
1859             ("rulers" create-rulers)
1860 ;;          ("saved position")
1861             ("scrolled windows" create-scrolled-windows)
1862             ("size group" create-size-group)
1863             ("shapes" create-shapes)
1864             ("spinbutton" create-spins)
1865             ("statusbar" create-statusbar)
1866             ("test idle" create-idle-test)
1867 ;;          ("test mainloop")
1868 ;;          ("test scrolling")
1869 ;;          ("test selection")
1870             ("test timeout" create-timeout-test)
1871             ("text" create-text)
1872             ("toggle buttons" create-toggle-buttons)
1873             ("toolbar" create-toolbar-window)
1874             ("tooltips" create-tooltips)
1875 ;;          ("tree" #|create-tree|#)
1876             ("UI manager" create-ui-manager)
1877 ))
1878         (main-window (make-instance 'window
1879                       :title "testgtk.lisp" :name "main_window"
1880                       :default-width 200 :default-height 400
1881                       :allow-grow t :allow-shrink nil))
1882         (scrolled-window (make-instance 'scrolled-window
1883                           :hscrollbar-policy :automatic
1884                           :vscrollbar-policy :automatic
1885                           :border-width 10))
1886         (close-button (make-instance 'button
1887                        :label "close" :can-default t
1888                        :signal (list 'clicked #'widget-destroy
1889                                      :object main-window))))
1890
1891     (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1892       (setf
1893        (window-icon main-window)
1894        (gdk:pixbuf-add-alpha icon t 254 254 252)))
1895
1896     ;; Main box
1897     (make-instance 'v-box
1898      :parent main-window
1899      :child-args '(:expand nil)
1900      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1901      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1902      :child (list (make-instance 'label
1903                    :label #-cmu(format nil "~A (~A)"
1904                                 (lisp-implementation-type)
1905                                 (lisp-implementation-version))
1906                           ;; The version string in CMUCL is far too long
1907                           #+cmu(lisp-implementation-type))
1908                   :fill nil)
1909      :child (list scrolled-window :expand t)
1910      :child (make-instance 'h-separator)
1911      :child (make-instance 'v-box
1912              :homogeneous nil :spacing 10 :border-width 10
1913              :child close-button))
1914
1915     (let ((content-box
1916            (make-instance 'v-box
1917             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1918             :children (mapcar #'(lambda (spec)
1919                                   (apply #'create-button spec))
1920                               button-specs))))
1921       (scrolled-window-add-with-viewport scrolled-window content-box))
1922
1923     (widget-grab-focus close-button)
1924     (widget-show-all main-window)
1925     main-window))
1926
1927 (clg-init)
1928 (create-main-window)