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

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