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

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