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