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