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.25 2005-03-13 18:16:08 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- (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 "This label is underlined!
 671 This one is underlined (こんにちは) in quite a funky fashion"
 672                       :justify :left
 673                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 674
 675
 676 ;;; Layout
 677
 678 (defun layout-expose (layout event)
 679   (when (eq (gdk:event-window event) (layout-bin-window layout))
 680     (with-slots (gdk:x gdk:y gdk:width gdk:height) event
 681       (let ((imin (truncate gdk:x 10))
 682             (imax (truncate (+ gdk:x gdk:width 9) 10))
 683             (jmin (truncate gdk:y 10))
 684             (jmax (truncate (+ gdk:y gdk:height 9) 10)))
 685
 686         (let ((window (layout-bin-window layout))
 687               (gc (style-black-gc (widget-style layout))))
 688           (loop
 689            for i from imin below imax
 690            do (loop
 691                for j from jmin below jmax
 692                unless (zerop (mod (+ i j) 2))
 693                do (gdk:draw-rectangle
 694                    window gc t (* 10 i) (* 10 j)
 695                    (1+ (mod i 10)) (1+ (mod j 10)))))))))
 696   nil)
 697
 698 (define-toplevel create-layout (window "Layout" :default-width 200
 699                                                 :default-height 200)
 700   (let ((layout (make-instance 'layout
 701                  :parent (make-instance 'scrolled-window :parent window)
 702                  :width 1600 :height 128000 :events '(:exposure)
 703                  :signal (list 'expose-event #'layout-expose :object t))))
 704
 705     (with-slots (hadjustment vadjustment) layout
 706       (setf
 707        (adjustment-step-increment hadjustment) 10.0
 708        (adjustment-step-increment vadjustment) 10.0))
 709
 710     (dotimes (i 16)
 711       (dotimes (j 16)
 712         (let ((text (format nil "Button ~D, ~D" i j)))
 713           (layout-put layout
 714            (make-instance (if (not (zerop (mod (+ i j) 2)))
 715                               'button
 716                             'label)
 717                           :label text :visible t)
 718            (* j 100) (* i 100)))))
 719
 720     (loop
 721      for i from 16 below 1280
 722      do (let ((text (format nil "Button ~D, ~D" i 0)))
 723           (layout-put layout
 724            (make-instance (if (not (zerop (mod i 2)))
 725                               'button
 726                             'label)
 727                           :label text :visible t)
 728            0 (* i 100))))))
 729
 730
 731
 732 ;;; List
 733
 734 (define-simple-dialog create-list (dialog "List" :default-height 400)
 735   (let* ((store (make-instance 'list-store
 736                  :column-types '(string int boolean)
 737                  :column-names '(:foo :bar :baz)
 738                  :initial-content '(#("First" 12321 nil)
 739                                     (:foo "Yeah" :baz t))))
 740          (tree (make-instance 'tree-view :model store)))
 741
 742     (loop
 743      with iter = (make-instance 'tree-iter)
 744      for i from 1 to 1000
 745      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 746
 747     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 748           (cell (make-instance 'cell-renderer-text)))
 749       (cell-layout-pack column cell :expand t)
 750       (cell-layout-add-attribute column cell 'text (column-index store :foo))
 751       (tree-view-append-column tree column))
 752
 753     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 754           (cell (make-instance 'cell-renderer-text :background "orange")))
 755       (cell-layout-pack column cell :expand t)
 756       (cell-layout-add-attribute column cell 'text (column-index store :bar))
 757       (tree-view-append-column tree column))
 758
 759     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 760           (cell (make-instance 'cell-renderer-text)))
 761       (cell-layout-pack column cell :expand t)
 762       (cell-layout-add-attribute column cell 'text (column-index store :baz))
 763       (tree-view-append-column tree column))
 764
 765     (make-instance 'v-box
 766      :parent dialog :border-width 10 :spacing 10
 767      :child (list
 768              (make-instance 'h-box
 769               :spacing 10
 770               :child (make-instance 'button
 771                       :label "Remove Selection"
 772                       :signal (list 'clicked
 773                                #'(lambda ()
 774                                    (let ((references
 775                                           (mapcar
 776                                            #'(lambda (path)
 777                                                (make-instance 'tree-row-reference :model store :path path))
 778                                            (tree-selection-get-selected-rows
 779                                             (tree-view-selection tree)))))
 780                                      (mapc
 781                                       #'(lambda (reference)
 782                                           (list-store-remove store reference))
 783                                       references))))))
 784              :expand nil)
 785      :child (list
 786              (make-instance 'h-box
 787               :spacing 10
 788               :child (make-instance 'check-button
 789                       :label "Show Headers" :active t
 790                       :signal (list 'toggled
 791                                #'(lambda (button)
 792                                    (setf
 793                                     (tree-view-headers-visible-p tree)
 794                                     (toggle-button-active-p button)))
 795                                :object t))
 796               :child (make-instance 'check-button
 797                       :label "Reorderable" :active nil
 798                       :signal (list 'toggled
 799                                #'(lambda (button)
 800                                    (setf
 801                                     (tree-view-reorderable-p tree)
 802                                     (toggle-button-active-p button)))
 803                                :object t))
 804               :child (list
 805                       (make-instance 'h-box
 806                        :child (make-instance 'label :label "Selection Mode: ")
 807                        :child (make-instance 'combo-box
 808                                :content '("Single" "Browse" "Multiple")
 809                                :active 0
 810                                :signal (list 'changed
 811                                         #'(lambda (combo-box)
 812                                             (setf
 813                                              (tree-selection-mode
 814                                               (tree-view-selection tree))
 815                                              (svref
 816                                               #(:single :browse :multiple)
 817                                               (combo-box-active combo-box))))
 818                                         :object t)))
 819                       :expand nil))
 820              :expand nil)
 821      :child (make-instance 'scrolled-window
 822             :child tree :hscrollbar-policy :automatic))))
 823
 824
 825 ;; Menus
 826
 827 (defun create-menu (depth tearoff)
 828   (unless (zerop depth)
 829     (let ((menu (make-instance 'menu)))
 830       (when tearoff
 831         (let ((menu-item (make-instance 'tearoff-menu-item)))
 832           (menu-shell-append menu menu-item)))
 833       (let ((group nil))
 834         (dotimes (i 5)
 835           (let ((menu-item
 836                  (make-instance 'radio-menu-item
 837                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 838             (if group
 839                 (add-to-radio-group menu-item group)
 840               (setq group menu-item))
 841             (unless (zerop (mod depth 2))
 842               (setf (check-menu-item-active-p menu-item) t))
 843             (menu-shell-append menu menu-item)
 844             (when (= i 3)
 845               (setf (widget-sensitive-p menu-item) nil))
 846             (let ((submenu (create-menu (1- depth) t)))
 847               (when submenu
 848                 (setf (menu-item-submenu menu-item) submenu))))))
 849       menu)))
 850
 851
 852 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 853   (let* ((main (make-instance 'v-box :parent dialog))
 854 ;        (accel-group (make-instance 'accel-group))
 855          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 856 ;    (window-add-accel-group dialog accel-group)
 857
 858     (let ((menu-item (make-instance 'menu-item
 859                       :label (format nil "test~%line2"))))
 860       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 861       (menu-shell-append menubar menu-item))
 862
 863     (let ((menu-item (make-instance 'menu-item :label "foo")))
 864       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 865       (menu-shell-append menubar menu-item))
 866
 867     (let ((menu-item (make-instance 'menu-item :label "bar")))
 868       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 869       (setf (menu-item-right-justified-p menu-item) t)
 870       (menu-shell-append menubar menu-item))
 871
 872     (make-instance 'v-box
 873      :spacing 10 :border-width 10 :parent main
 874      :child (make-instance 'combo-box
 875              :active 3
 876              :content (loop
 877                        for i from 1 to 5
 878                        collect (format nil "Item ~D" i))))
 879
 880     (widget-show-all main)))
 881
 882
 883 ;;; Notebook
 884
 885 (defun create-notebook-page (notebook page-num book-closed)
 886   (let* ((title (format nil "Page ~D" page-num))
 887          (page (make-instance 'frame :label title :border-width 10))
 888          (v-box (make-instance 'v-box
 889                  :homogeneous t :border-width 10 :parent page)))
 890
 891     (make-instance 'h-box
 892      :parent (list v-box :fill nil :padding 5) :homogeneous t
 893      :child-args '(:padding 5)
 894      :child (make-instance 'check-button
 895              :label "Fill Tab" :active t
 896              :signal (list 'toggled
 897                            #'(lambda (button)
 898                                (setf
 899                                 (notebook-child-tab-fill-p page)
 900                                 (toggle-button-active-p button)))
 901                            :object t))
 902      :child (make-instance 'check-button
 903              :label "Expand Tab"
 904              :signal (list 'toggled
 905                            #'(lambda (button)
 906                                (setf
 907                                 (notebook-child-tab-expand-p page)
 908                                 (toggle-button-active-p button)))
 909                            :object t))
 910      :child (make-instance 'check-button
 911              :label "Pack end"
 912              :signal (list 'toggled
 913                            #'(lambda (button)
 914                                (setf
 915                                 (notebook-child-tab-pack page)
 916                                 (if (toggle-button-active-p button)
 917                                     :end
 918                                   :start)))
 919                            :object t))
 920      :child (make-instance 'button
 921              :label "Hide page"
 922              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 923
 924     (let ((label-box (make-instance 'h-box
 925                       :show-children t
 926                       :child-args '(:expand nil)
 927                       :child (make-instance 'image :pixbuf book-closed)
 928                       :child (make-instance 'label :label title)))
 929           (menu-box (make-instance 'h-box
 930                      :show-children t
 931                      :child-args '(:expand nil)
 932                      :child (make-instance 'image :pixbuf book-closed)
 933                      :child (make-instance 'label :label title))))
 934
 935       (widget-show-all page)
 936       (notebook-append notebook page label-box menu-box))))
 937
 938
 939 (define-simple-dialog create-notebook (dialog "Notebook")
 940   (let ((main (make-instance 'v-box :parent dialog)))
 941     (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
 942           (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
 943           (notebook (make-instance 'notebook
 944                      :border-width 10 :tab-pos :top :parent main)))
 945       (flet ((set-image (page func pixbuf)
 946                (setf
 947                 (image-pixbuf
 948                  (first (container-children (funcall func notebook page))))
 949                 pixbuf)))
 950         (signal-connect notebook 'switch-page
 951          #'(lambda (pointer page)
 952              (declare (ignore pointer))
 953              (set-image page #'notebook-menu-label book-open)
 954              (set-image page #'notebook-tab-label book-open)
 955              (when (slot-boundp notebook 'current-page)
 956                (let ((curpage (notebook-current-page notebook)))
 957                  (set-image curpage #'notebook-menu-label book-closed)
 958                  (set-image curpage #'notebook-tab-label book-closed))))))
 959       (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 960
 961       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 962
 963       (make-instance 'h-box
 964        :spacing 5 :border-width 10
 965        :parent (list main :expand nil)
 966        :child-args '(:fill nil)
 967        :child (make-instance 'check-button
 968                :label "Popup menu"
 969                :signal (list 'clicked
 970                         #'(lambda (button)
 971                             (if (toggle-button-active-p button)
 972                                 (notebook-popup-enable notebook)
 973                                 (notebook-popup-disable notebook)))
 974                         :object t))
 975        :child (make-instance 'check-button
 976                :label "Homogeneous tabs"
 977                :signal (list 'clicked
 978                         #'(lambda (button)
 979                             (setf
 980                              (notebook-homogeneous-p notebook)
 981                              (toggle-button-active-p button)))
 982                         :object t)))
 983
 984       (make-instance 'h-box
 985        :spacing 5 :border-width 10
 986        :parent (list main :expand nil)
 987        :child-args '(:expand nil)
 988        :child (make-instance 'label :label "Notebook Style: ")
 989        :child (let ((scrollable-p nil))
 990                 (make-instance 'combo-box
 991                  :content '("Standard" "No tabs" "Scrollable") :active 0
 992                  :signal (list 'changed
 993                           #'(lambda (combo-box)
 994                               (case (combo-box-active combo-box)
 995                                 (0
 996                                  (setf (notebook-show-tabs-p notebook) t)
 997                                  (when scrollable-p
 998                                    (setq scrollable-p nil)
 999                                    (setf (notebook-scrollable-p notebook) nil)
1000                                    (loop repeat 10
1001                                     do (notebook-remove-page notebook 5))))
1002                                 (1
1003                                  (setf (notebook-show-tabs-p notebook) nil)
1004                                  (when scrollable-p
1005                                    (setq scrollable-p nil)
1006                                    (setf (notebook-scrollable-p notebook) nil)
1007                                    (loop repeat 10
1008                                      do (notebook-remove-page notebook 5))))
1009                                 (2
1010                                  (unless scrollable-p
1011                                    (setq scrollable-p t)
1012                                    (setf (notebook-show-tabs-p notebook) t)
1013                                    (setf (notebook-scrollable-p notebook) t)
1014                                    (loop for i from 6 to 15
1015                                     do (create-notebook-page notebook i book-closed))))))
1016                           :object t)))
1017        :child (make-instance 'button
1018                :label "Show all Pages"
1019                :signal (list 'clicked
1020                         #'(lambda ()
1021                             (map-container nil #'widget-show notebook)))))
1022
1023       (make-instance 'h-box
1024        :spacing 5 :border-width 10
1025        :parent (list main :expand nil)
1026        :child (make-instance 'button
1027                :label "prev"
1028                :signal (list 'clicked #'notebook-prev-page :object notebook))
1029        :child (make-instance 'button
1030                :label "next"
1031                :signal (list 'clicked #'notebook-next-page :object notebook))
1032        :child (make-instance 'button
1033                :label "rotate"
1034                :signal (let ((tab-pos 0))
1035                          (list 'clicked
1036                           #'(lambda ()
1037                               (setq tab-pos (mod (1+ tab-pos) 4))
1038                               (setf
1039                                (notebook-tab-pos notebook)
1040                                (svref #(:top :right :bottom :left) tab-pos))))))))
1041     (widget-show-all main)))
1042
1043
1044 ;;; Panes
1045
1046 (defun toggle-resize (child)
1047   (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1048
1049 (defun toggle-shrink (child)
1050   (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1051
1052 (defun create-pane-options (paned frame-label label1 label2)
1053   (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1054     (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1055     (let ((check-button (make-instance 'check-button :label "Resize")))
1056       (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1057       (signal-connect check-button 'toggled
1058        #'toggle-resize :object (paned-child1 paned)))
1059     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1060       (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1061       (signal-connect check-button 'toggled
1062        #'toggle-shrink :object (paned-child1 paned)))
1063
1064     (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1065     (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1066       (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1067       (signal-connect check-button 'toggled
1068        #'toggle-resize :object (paned-child2 paned)))
1069     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1070       (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1071       (signal-connect check-button 'toggled
1072        #'toggle-shrink :object (paned-child2 paned)))
1073     (make-instance 'frame :label frame-label :border-width 4 :child table)))
1074
1075 (define-toplevel create-panes (window "Panes")
1076   (let* ((hpaned (make-instance 'h-paned
1077                   :child1 (make-instance 'frame
1078                            :width-request 60 :height-request 60
1079                            :shadow-type :in
1080                            :child (make-instance 'button :label "Hi there"))
1081                   :child2 (make-instance 'frame
1082                            :width-request 80 :height-request 60
1083                            :shadow-type :in)))
1084          (vpaned (make-instance 'v-paned
1085                   :border-width 5
1086                   :child1 hpaned
1087                   :child2 (make-instance 'frame
1088                            :width-request 80 :height-request 60
1089                            :shadow-type :in))))
1090
1091     (make-instance 'v-box
1092      :parent window
1093      :child-args '(:expand nil)
1094      :child (list vpaned :expand t)
1095      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1096      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1097
1098
1099 ;;; Progress bar
1100
1101 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1102   (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1103          (activity-mode-button (make-instance 'check-button
1104                                 :label "Activity mode"))
1105          (timer (timeout-add 100
1106                  #'(lambda ()
1107                      (if (toggle-button-active-p activity-mode-button)
1108                          (progress-bar-pulse progress)
1109                        (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1110                          (setf
1111                           (progress-bar-fraction progress)
1112                           (if (> fract 1.0)
1113                               0.0
1114                             fract))))
1115                      t))))
1116
1117     (make-instance 'v-box
1118      :parent dialog :border-width 10 :spacing 10
1119      :child progress
1120      :child activity-mode-button)
1121
1122     (signal-connect dialog 'destroy
1123      #'(lambda () (when timer (timeout-remove timer))))))
1124
1125
1126 ;;; Radio buttons
1127
1128 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1129   (make-instance 'v-box
1130    :parent dialog :border-width 10 :spacing 10
1131    :children (make-radio-group 'radio-button
1132               '((:label "button1") (:label "button2") (:label "button3"))
1133               nil)))
1134
1135
1136 ;;; Rangle controls
1137
1138 (define-simple-dialog create-range-controls (dialog "Range controls")
1139   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1140     (make-instance 'v-box
1141      :parent dialog :border-width 10 :spacing 10
1142      :child (make-instance 'h-scale
1143              :width-request 150 :adjustment adjustment :inverted t
1144              :update-policy :delayed :digits 1 :draw-value t)
1145      :child (make-instance 'h-scrollbar
1146              :adjustment adjustment :update-policy :continuous))))
1147
1148
1149 ;;; Reparent test
1150
1151 (define-simple-dialog create-reparent (dialog "Reparent")
1152   (let ((main (make-instance 'h-box
1153                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1154         (label (make-instance 'label :label "Hello World")))
1155
1156     (flet ((create-frame (title)
1157              (let* ((frame (make-instance 'frame :label title :parent main))
1158                     (box (make-instance 'v-box
1159                           :spacing 5 :border-width 5 :parent frame))
1160                     (button (make-instance 'button
1161                              :label "switch" :parent (list box :expand nil))))
1162                (signal-connect button 'clicked
1163                 #'(lambda ()
1164                     (widget-reparent label box)))
1165                box)))
1166
1167       (box-pack-start (create-frame "Frame 1") label nil t 0)
1168       (create-frame "Frame 2"))
1169     (widget-show-all main)))
1170
1171
1172 ;;; Rulers
1173
1174 (define-toplevel create-rulers (window "Rulers"
1175                                 :default-width 300 :default-height 300
1176                                 :events '(:pointer-motion :pointer-motion-hint))
1177   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1178         (h-ruler (make-instance 'h-ruler
1179                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1180                   :position 0.0d0 :max-size 20.0d0))
1181         (v-ruler (make-instance 'v-ruler
1182                   :lower 5.0d0 :upper 15.0d0
1183                   :position 0.0d0 :max-size 20.0d0)))
1184     (signal-connect window 'motion-notify-event
1185      #'(lambda (event)
1186          (widget-event h-ruler event)
1187          (widget-event v-ruler event)))
1188     (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1189     (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1190
1191
1192 ;;; Scrolled window
1193
1194 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1195                                                       :default-width 300
1196                                                       :default-height 300)
1197   (let* ((scrolled-window
1198           (make-instance 'scrolled-window
1199            :parent dialog :border-width 10
1200            :vscrollbar-policy :automatic
1201            :hscrollbar-policy :automatic))
1202          (table
1203           (make-instance 'table
1204            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1205            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1206            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1207
1208       (scrolled-window-add-with-viewport scrolled-window table)
1209       (dotimes (i 20)
1210         (dotimes (j 20)
1211           (let ((button
1212                  (make-instance 'toggle-button
1213                   :label (format nil "button (~D,~D)~%" i j))))
1214             (table-attach table button i (1+ i) j (1+ j)))))
1215       (widget-show-all scrolled-window)))
1216
1217
1218 ;;; Size group
1219
1220 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1221   (let ((size-group (make-instance 'size-group)))
1222     (flet ((create-frame (label rows)
1223              (let ((table (make-instance 'table
1224                            :n-rows (length rows) :n-columns 2 :homogeneous nil
1225                            :row-spacing 5 :column-spacing 10 :border-width 5)))
1226                (loop
1227                 for row in rows
1228                 for i from 0
1229                 do (table-attach table
1230                     (create-label (first row) :xalign 0 :yalign 1)
1231                     0 1 i (1+ i) :x-options '(:expand :fill))
1232                    (let ((combo (make-instance 'combo-box
1233                                  :content (rest row) :active 0)))
1234                      (size-group-add-widget size-group combo)
1235                      (table-attach table combo 1 2 i (1+ i))))
1236                (make-instance 'frame :label label :child table))))
1237
1238       (make-instance 'v-box
1239        :parent dialog :border-width 5 :spacing 5
1240        :child (create-frame "Color Options"
1241                '(("Foreground" "Red" "Green" "Blue")
1242                  ("Background" "Red" "Green" "Blue")))
1243        :child (create-frame "Line Options"
1244                '(("Dashing" "Solid" "Dashed" "Dotted")
1245                  ("Line ends" "Square" "Round" "Arrow")))
1246        :child (create-check-button "Enable grouping"
1247                #'(lambda (active)
1248                    (setf
1249                     (size-group-mode size-group)
1250                     (if active :horizontal :none)))
1251                t)))))
1252
1253
1254 ;;; Shapes
1255
1256 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1257   (let ((window
1258          (make-instance 'window
1259           :type type :default-width 100 :default-height 100
1260           :events '(:button-motion :pointer-motion-hint :button-press)
1261           :signal (list 'destroy destroy))))
1262
1263     (widget-realize window)
1264     (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1265       (let ((fixed (make-instance 'fixed :parent window)))
1266         (fixed-put fixed (create-image-widget source mask) px py))
1267       (widget-shape-combine-mask window mask px py))
1268
1269     (let ((x-offset 0)
1270           (y-offset 0))
1271       (declare (fixnum x-offset y-offset))
1272       (signal-connect window 'button-press-event
1273        #'(lambda (event)
1274            (when (typep event 'gdk:button-press-event)
1275              (setq x-offset (truncate (gdk:event-x event)))
1276              (setq y-offset (truncate (gdk:event-y event)))
1277              (grab-add window)
1278              (gdk:pointer-grab (widget-window window)
1279               :events '(:button-release :button-motion :pointer-motion-hint)
1280               :owner-events t :time event))))
1281
1282       (signal-connect window 'button-release-event
1283        #'(lambda (event)
1284            (grab-remove window)
1285            (gdk:pointer-ungrab event)))
1286
1287       (signal-connect window 'motion-notify-event
1288        #'(lambda (event)
1289            (declare (ignore event))
1290            (multiple-value-bind (win xp yp mask)
1291                (gdk:window-get-pointer root-window)
1292              (declare (ignore mask win) (fixnum xp yp))
1293              (window-move window (- xp x-offset) (- yp y-offset))))))
1294
1295     (window-move window x y)
1296     (widget-show-all window)
1297     window))
1298
1299
1300 (let ((modeller nil)
1301       (sheets nil)
1302       (rings nil))
1303   (defun create-shapes ()
1304     (let ((root-window (gdk:get-root-window)))
1305       (if (not modeller)
1306           (setq
1307            modeller
1308            (create-shape-icon
1309             "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1310             #'(lambda () (setq modeller nil))))
1311         (widget-destroy modeller))
1312
1313       (if (not sheets)
1314           (setq
1315            sheets
1316            (create-shape-icon
1317             "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1318             #'(lambda () (setq sheets nil))))
1319         (widget-destroy sheets))
1320
1321       (if (not rings)
1322           (setq
1323            rings
1324            (create-shape-icon
1325             "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1326             #'(lambda () (setq rings nil))))
1327         (widget-destroy rings)))))
1328
1329
1330
1331 ;;; Spin buttons
1332
1333 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1334   (let ((main (make-instance 'v-box
1335                :spacing 5 :border-width 10 :parent dialog)))
1336
1337     (flet ((create-date-spinner (label adjustment shadow-type)
1338              (declare (ignore shadow-type))
1339              (make-instance 'v-box
1340               :child-args '(:expand nil)
1341               :child (make-instance 'label
1342                       :label label :xalign 0.0 :yalign 0.5)
1343               :child (make-instance 'spin-button
1344                       :adjustment adjustment :wrap t))))
1345       (multiple-value-bind (sec min hour date month year day daylight-p zone)
1346           (get-decoded-time)
1347         (declare (ignore sec min hour day daylight-p zone))
1348         (make-instance 'frame
1349          :label "Not accelerated" :parent main
1350          :child (make-instance 'h-box
1351                  :border-width 10
1352                  :child-args '(:padding 5)
1353                  :child (create-date-spinner "Day : "
1354                          (adjustment-new date 1 31 1 5 0) :out)
1355                  :child (create-date-spinner "Month : "
1356                          (adjustment-new month 1 12 1 5 0) :etched-in)
1357                  :child (create-date-spinner "Year : "
1358                          (adjustment-new year 0 2100 1 100 0) :in)))))
1359
1360     (let ((spinner1 (make-instance 'spin-button
1361                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1362                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1363           (spinner2 (make-instance 'spin-button
1364                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1365                      :climb-rate 1.0 :wrap t))
1366           (value-label (make-instance 'label :label "0")))
1367       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1368        #'(lambda ()
1369            (setf
1370             (spin-button-digits spinner1)
1371             (floor (spin-button-value spinner2)))))
1372
1373       (make-instance 'frame
1374        :label "Accelerated" :parent main
1375        :child (make-instance 'v-box
1376                :border-width 5
1377                :child (list
1378                        (make-instance 'h-box
1379                         :child-args '(:padding 5)
1380                         :child (make-instance 'v-box
1381                                 :child (make-instance 'label
1382                                         :label "Value :"
1383                                         :xalign 0.0 :yalign 0.5)
1384                                 :child spinner1)
1385                         :child (make-instance 'v-box
1386                                 :child (make-instance 'label
1387                                         :label "Digits :"
1388                                         :xalign 0.0 :yalign 0.5)
1389                                 :child spinner2))
1390                        :expand nil :padding 5)
1391                :child (make-instance 'check-button
1392                        :label "Snap to 0.5-ticks" :active t
1393                        :signal (list 'clicked
1394                                 #'(lambda (button)
1395                                     (setf
1396                                      (spin-button-snap-to-ticks-p spinner1)
1397                                      (toggle-button-active-p button)))
1398                                 :object t))
1399                :child (make-instance 'check-button
1400                        :label "Numeric only input mode" :active t
1401                        :signal (list 'clicked
1402                                 #'(lambda (button)
1403                                     (setf
1404                                      (spin-button-numeric-p spinner1)
1405                                      (toggle-button-active-p button)))
1406                                 :object t))
1407                :child value-label
1408                :child (list
1409                        (make-instance 'h-box
1410                         :child-args '(:padding 5)
1411                         :child (make-instance 'button
1412                                 :label "Value as Int"
1413                                 :signal (list 'clicked
1414                                          #'(lambda ()
1415                                              (setf
1416                                               (label-label value-label)
1417                                               (format nil "~D"
1418                                                (spin-button-value-as-int
1419                                                 spinner1))))))
1420                         :child (make-instance 'button
1421                                 :label "Value as Float"
1422                                 :signal (list 'clicked
1423                                          #'(lambda ()
1424                                              (setf
1425                                               (label-label value-label)
1426                                               (format nil
1427                                                (format nil "~~,~DF"
1428                                                 (spin-button-digits spinner1))
1429                                                (spin-button-value spinner1)))))))
1430                        :padding 5 :expand nil))))
1431     (widget-show-all main)))
1432
1433
1434 ;;; Statusbar
1435
1436 (define-toplevel create-statusbar (window "Statusbar")
1437   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1438         (close-button (create-button '("close" :can-default t)
1439                        #'widget-destroy :object window))
1440         (counter 0))
1441
1442     (signal-connect statusbar 'text-popped
1443      #'(lambda (context-id text)
1444          (declare (ignore context-id))
1445          (format nil "Popped: ~A~%" text)))
1446
1447     (make-instance 'v-box
1448      :parent window
1449      :child (make-instance 'v-box
1450              :border-width 10 :spacing 10
1451              :child (create-button "push something"
1452                      #'(lambda ()
1453                          (statusbar-push statusbar 1
1454                           (format nil "something ~D" (incf counter)))))
1455              :child (create-button "pop"
1456                      #'(lambda ()
1457                          (statusbar-pop statusbar 1)))
1458              :child (create-button "steal #4"
1459                      #'(lambda ()
1460                          (statusbar-remove statusbar 1 4)))
1461              :child (create-button "dump stack")
1462              :child (create-button "test contexts"))
1463      :child (list (make-instance 'h-separator) :expand nil)
1464      :child (list
1465              (make-instance 'v-box :border-width 10 :child close-button)
1466              :expand nil)
1467      :child (list statusbar :expand nil))
1468
1469     (widget-grab-focus close-button)))
1470
1471
1472 ;;; Idle test
1473
1474 (define-simple-dialog create-idle-test (dialog "Idle Test")
1475   (let ((label (make-instance 'label
1476                 :label "count: 0" :xpad 10 :ypad 10))
1477         (idle nil)
1478         (count 0))
1479     (signal-connect dialog 'destroy
1480      #'(lambda () (when idle (idle-remove idle))))
1481
1482     (make-instance 'v-box
1483      :parent dialog :border-width 10 :spacing 10
1484      :child label
1485      :child (make-instance 'frame
1486              :label "Label Container" :border-width 5
1487              :child(make-instance 'v-box
1488                    :children (make-radio-group 'radio-button
1489                               '((:label "Resize-Parent" :value :parent :active t)
1490                                 (:label "Resize-Queue" :value :queue)
1491                                 (:label "Resize-Immediate" :value :immediate))
1492                               #'(lambda (mode)
1493                                   (setf
1494                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1495
1496     (dialog-add-button dialog "Start"
1497      #'(lambda ()
1498          (unless idle
1499            (setq idle
1500             (idle-add
1501              #'(lambda ()
1502                  (incf count)
1503                  (setf (label-label label) (format nil "count: ~D" count))
1504                  t))))))
1505
1506     (dialog-add-button dialog "Stop"
1507      #'(lambda ()
1508          (when idle
1509            (idle-remove idle)
1510            (setq idle nil))))))
1511
1512
1513
1514 ;;; Timeout test
1515
1516 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1517   (let ((label (make-instance 'label
1518                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1519         (timer nil)
1520         (count 0))
1521     (signal-connect dialog 'destroy
1522      #'(lambda () (when timer (timeout-remove timer))))
1523
1524     (dialog-add-button dialog "Start"
1525      #'(lambda ()
1526          (unless timer
1527            (setq timer
1528             (timeout-add 100
1529              #'(lambda ()
1530                  (incf count)
1531                  (setf (label-label label) (format nil "count: ~D" count))
1532                  t))))))
1533
1534     (dialog-add-button dialog "Stop"
1535      #'(lambda ()
1536          (when timer
1537            (timeout-remove timer)
1538            (setq timer nil))))))
1539
1540
1541 ;;; Text
1542
1543 (define-simple-dialog create-text (dialog "Text" :default-width 400
1544                                                  :default-height 400)
1545   (let* ((text-view (make-instance 'text-view
1546                      :border-width 10 :visible t :wrap-mode :word))
1547          (buffer (text-view-buffer text-view))
1548          (active-tags ()))
1549
1550     (text-buffer-create-tag buffer "Bold" :weight :bold)
1551     (text-buffer-create-tag buffer "Italic" :style :italic)
1552     (text-buffer-create-tag buffer "Underline" :underline :single)
1553
1554     (flet ((create-toggle-callback (tag-name)
1555              (let ((tag (text-tag-table-lookup
1556                          (text-buffer-tag-table buffer) tag-name)))
1557                #'(lambda (active)
1558                    (unless (eq (and (find tag active-tags) t) active)
1559                      ;; user activated
1560                      (if active
1561                          (push tag active-tags)
1562                        (setq active-tags (delete tag active-tags)))
1563                      (multiple-value-bind (non-zero-p start end)
1564                          (text-buffer-get-selection-bounds buffer)
1565                        (declare (ignore non-zero-p))
1566                        (if active
1567                            (text-buffer-apply-tag buffer tag start end)
1568                          (text-buffer-remove-tag buffer tag start end))))))))
1569
1570       (let* ((actions
1571               (make-instance 'action-group
1572                :action (create-toggle-action
1573                         "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1574                         (create-toggle-callback "Bold"))
1575                :action (create-toggle-action
1576                         "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1577                         (create-toggle-callback "Italic"))
1578                :action (create-toggle-action
1579                         "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1580                         (create-toggle-callback "Underline"))))
1581              (ui (make-instance 'ui-manager)))
1582
1583         (ui-manager-insert-action-group ui actions)
1584         (ui-manager-add-ui ui
1585          '((:toolbar "ToolBar"
1586             (:toolitem "Bold")
1587             (:toolitem "Italic")
1588             (:toolitem "Underline"))))
1589
1590         ;; Callback to activate/deactivate toolbar buttons when cursor
1591         ;; is moved
1592         (signal-connect buffer 'mark-set
1593          #'(lambda (location mark)
1594              (declare (ignore mark))
1595              (text-tag-table-foreach (text-buffer-tag-table buffer)
1596               #'(lambda (tag)
1597                   (let ((active
1598                          (or
1599                           (and
1600                            (text-iter-has-tag-p location tag)
1601                            (not (text-iter-begins-tag-p location tag)))
1602                           (text-iter-ends-tag-p location tag))))
1603                     (unless (eq active (and (find tag active-tags) t))
1604                       (if active
1605                           (push tag active-tags)
1606                         (setq active-tags (delete tag active-tags)))
1607                       (setf
1608                        (toggle-action-active-p
1609                         (action-group-get-action actions (text-tag-name tag)))
1610                        active)))))))
1611
1612         ;; Callback to apply active tags when a character is inserted
1613         (signal-connect buffer 'insert-text
1614          #'(lambda (iter &rest args)
1615              (declare (ignore args))
1616              (let ((before (text-buffer-get-iter-at-offset buffer
1617                             (1- (text-iter-offset iter)))))
1618                (loop
1619                 for tag in active-tags
1620                 do (text-buffer-apply-tag buffer tag before iter))))
1621          :after t)
1622
1623         (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1624         (container-add dialog text-view)))))
1625
1626
1627 ;;; Toggle buttons
1628
1629 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1630   (make-instance 'v-box
1631    :border-width 10 :spacing 10 :parent dialog
1632       :children (loop
1633               for n from 1 to 3
1634               collect (make-instance 'toggle-button
1635                        :label (format nil "Button~D" (1+ n))))))
1636
1637
1638
1639 ;;; Toolbar test
1640
1641 (defun create-toolbar (window)
1642   (make-instance 'toolbar
1643    :show-tooltips t :show-arrow nil
1644
1645    ;; Insert a stock item
1646    :child (make-instance 'tool-button
1647            :stock  "gtk-quit"
1648            :tip-text "Destroy toolbar"
1649            :tip-private "Toolbar/Quit"
1650            :signal (list 'clicked #'(lambda () (widget-destroy window))))
1651
1652    :child (make-instance 'separator-tool-item)
1653
1654    :child (make-instance 'tool-button
1655            :label "Horizontal" :stock "gtk-go-forward"
1656            :tip-text "Horizontal toolbar layout"
1657            :tip-private "Toolbar/Horizontal"
1658            :signal (list 'clicked
1659                     #'(lambda (toolbar)
1660                         (setf (toolbar-orientation toolbar) :horizontal))
1661                     :object :parent))
1662
1663    :child (make-instance 'tool-button
1664            :label "Vertical" :stock "gtk-go-down"
1665            :tip-text "Vertical toolbar layout"
1666            :tip-private "Toolbar/Vertical"
1667            :signal (list 'clicked
1668                     #'(lambda (toolbar)
1669                         (setf (toolbar-orientation toolbar) :vertical))
1670                     :object :parent))
1671
1672    :child (make-instance 'separator-tool-item)
1673
1674    :children (make-radio-group 'radio-tool-button
1675               '((:label "Icons" :stock "gtk-justify-left"
1676                  :tip-text "Only show toolbar icons"
1677                  :tip-private "Toolbar/IconsOnly"
1678                  :value :icons)
1679                 (:label "Both" :stock "gtk-justify-center"
1680                  :tip-text "Show toolbar icons and text"
1681                  :tip-private "Toolbar/Both"
1682                  :value :both :active t)
1683                 (:label "Text" :stock "gtk-justify-right"
1684                  :tip-text "Show toolbar text"
1685                  :tip-private "Toolbar/TextOnly"
1686                  :value :text))
1687               (list
1688                #'(lambda (toolbar style)
1689                    (setf (toolbar-style toolbar) style))
1690                :object :parent))
1691
1692    :child (make-instance 'separator-tool-item)
1693
1694    :child (make-instance 'tool-item
1695            :child (make-instance 'entry)
1696            :tip-text "This is an unusable GtkEntry"
1697            :tip-private "Hey don't click me!")
1698
1699    :child (make-instance 'separator-tool-item)
1700
1701    :child (make-instance 'tool-button
1702            :label "Enable" :stock "gtk-add"
1703            :tip-text "Enable tooltips"
1704            :tip-private "Toolbar/EnableTooltips"
1705            :signal (list 'clicked
1706                     #'(lambda (toolbar)
1707                         (setf (toolbar-show-tooltips-p toolbar) t))
1708                     :object :parent))
1709
1710    :child (make-instance 'tool-button
1711            :label "Disable" :stock "gtk-remove"
1712            :tip-text "Disable tooltips"
1713            :tip-private "Toolbar/DisableTooltips"
1714            :signal (list 'clicked
1715                     #'(lambda (toolbar)
1716                         (setf (toolbar-show-tooltips-p toolbar) nil))
1717                     :object :parent))
1718
1719 ;;    :child (make-instance 'separator-tool-item)
1720
1721 ;;    :child (make-instance 'tool-button
1722 ;;         :label "GTK" :icon #p"clg:examples;gtk.png"
1723 ;;         :tip-text "GTK+ Logo"
1724 ;;         :tip-private "Toolbar/GTK+")
1725    ))
1726
1727 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1728   (container-add window (create-toolbar window)))
1729
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)