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.10 2004/12/05 13:57:10 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     (widget-show-all table)))
 243
 244
 245 ;; Calenadar
 246
 247 (define-simple-dialog create-calendar (dialog "Calendar")
 248   (make-instance 'v-box
 249    :parent dialog :border-width 10 :show-all t
 250    :child (make-instance 'calendar)))
 251
 252
 253 ;;; Check buttons
 254
 255 (define-simple-dialog create-check-buttons (dialog "Check Buttons")
 256   (make-instance 'v-box
 257    :border-width 10 :spacing 10 :parent dialog :show-all t
 258    :children (loop
 259               for n from 1 to 3
 260               collect (make-instance 'check-button
 261                        :label (format nil "Button~D" n)))))
 262
 263
 264
 265 ;;; Color selection
 266
 267 (define-dialog create-color-selection (dialog "Color selection dialog"
 268                                        'color-selection-dialog
 269                                        :allow-grow nil :allow-shrink nil)
 270   (with-slots (action-area colorsel) dialog
 271 ;;     This seg faults for some unknown reason
 272 ;;     (let ((button (make-instance 'check-button :label "Show Palette")))
 273 ;;       (dialog-add-action-widget dialog button
 274 ;;        #'(lambda ()
 275 ;;        (setf
 276 ;;         (color-selection-has-palette-p colorsel)
 277 ;;         (toggle-button-active-p button)))))
 278
 279     (container-add action-area
 280      (create-check-button "Show Opacity"
 281       #'(lambda (state)
 282           (setf (color-selection-has-opacity-control-p colorsel) state))))
 283
 284     (container-add action-area
 285      (create-check-button "Show Palette"
 286       #'(lambda (state)
 287           (setf (color-selection-has-palette-p colorsel) state))))
 288
 289     (signal-connect dialog :ok
 290      #'(lambda ()
 291          (let ((color (color-selection-current-color colorsel)))
 292            (format t "Selected color: ~A~%" color)
 293            (setf (color-selection-current-color colorsel) color)
 294            (widget-hide dialog))))
 295
 296     (signal-connect dialog :cancel #'widget-destroy :object t)))
 297
 298
 299 ;;; Cursors
 300
 301 (defun clamp (n min-val max-val)
 302   (declare (number n min-val max-val))
 303   (max (min n max-val) min-val))
 304
 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-text label) (string-downcase cursor))
 312 ;;     (setf (widget-cursor drawing-area) cursor)))
 313
 314
 315 ; (define-standard-dialog create-cursors "Cursors"
 316 ;   (setf (container-border-width main-box) 10)
 317 ;   (setf (box-spacing main-box) 5)
 318 ;   (let* ((hbox (hbox-new nil 0))
 319 ;        (label (create-label "Cursor Value : "))
 320 ;        (adj (adjustment-new 0 0 152 2 10 0))
 321 ;        (spinner (spin-button-new adj 0 0)))
 322 ;     (setf (container-border-width hbox) 5)
 323 ;     (box-pack-start main-box hbox nil t 0)
 324 ;     (setf (misc-xalign label) 0)
 325 ;     (setf (misc-yalign label) 0.5)
 326 ;     (box-pack-start hbox label nil t 0)
 327 ;     (box-pack-start hbox spinner t t 0)
 328
 329 ;     (let ((frame (make-frame
 330 ;                 :shadow-type :etched-in
 331 ;                 :label-xalign 0.5
 332 ;                 :label "Cursor Area"
 333 ;                 :border-width 10
 334 ;                 :parent main-box
 335 ;                 :visible t))
 336 ;         (drawing-area (drawing-area-new)))
 337 ;       (setf (widget-width drawing-area) 80)
 338 ;       (setf (widget-height drawing-area) 80)
 339 ;       (container-add frame drawing-area)
 340 ;       (signal-connect
 341 ;        drawing-area 'expose-event
 342 ;        #'(lambda (event)
 343 ;          (declare (ignore event))
 344 ;          (multiple-value-bind (width height)
 345 ;              (drawing-area-size drawing-area)
 346 ;            (let* ((drawable (widget-window drawing-area))
 347 ;                   (style (widget-style drawing-area))
 348 ;                   (white-gc (style-get-gc style :white))
 349 ;                   (gray-gc (style-get-gc style :background :normal))
 350 ;                   (black-gc (style-get-gc style :black)))
 351 ;              (gdk:draw-rectangle
 352 ;               drawable white-gc t 0 0 width (floor height 2))
 353 ;              (gdk:draw-rectangle
 354 ;               drawable black-gc t 0 (floor height 2) width (floor height 2))
 355 ;              (gdk:draw-rectangle
 356 ;               drawable gray-gc t (floor width 3) (floor height 3)
 357 ;               (floor width 3) (floor height 3))))
 358 ;            t))
 359 ;       (setf (widget-events drawing-area) '(:exposure :button-press))
 360 ;       (signal-connect
 361 ;        drawing-area 'button-press-event
 362 ;        #'(lambda (event)
 363 ;          (when (and
 364 ;                 (eq (gdk:event-type event) :button-press)
 365 ;                 (or
 366 ;                  (= (gdk:event-button event) 1)
 367 ;                  (= (gdk:event-button event) 3)))
 368 ;            (spin-button-spin
 369 ;             spinner
 370 ;             (if (= (gdk:event-button event) 1)
 371 ;                 :step-forward
 372 ;               :step-backward)
 373 ;             0)
 374 ;            t)))
 375 ;       (widget-show drawing-area)
 376
 377 ;     (let ((label (make-label
 378 ;                 :visible t
 379 ;                 :label "XXX"
 380 ;                 :parent main-box)))
 381 ;       (setf (box-child-expand-p #|main-box|# label) nil)
 382 ;       (signal-connect
 383 ;        spinner 'changed
 384 ;        #'(lambda ()
 385 ;          (set-cursor spinner drawing-area label)))
 386
 387 ;       (widget-realize drawing-area)
 388 ;       (set-cursor spinner drawing-area label)))))
 389
 390
 391
 392 ;;; Dialog
 393
 394 (let ((dialog nil))
 395   (defun create-dialog ()
 396     (unless dialog
 397       (setq dialog (make-instance 'dialog
 398                     :title "Dialog" :default-width 200
 399                     :button "Toggle"
 400                     :button (list "gtk-ok" #'widget-destroy :object t)
 401                     :signal (list 'destroy
 402                              #'(lambda ()
 403                                  (setq dialog nil)))))
 404
 405       (let ((label (make-instance 'label
 406                     :label "Dialog Test" :xpad 10 :ypad 10 :visible t
 407                     :parent dialog)))
 408         (signal-connect dialog "Toggle"
 409          #'(lambda ()
 410              (if (widget-visible-p label)
 411                  (widget-hide label)
 412                (widget-show label))))))
 413
 414     (if (widget-visible-p dialog)
 415         (widget-hide dialog)
 416        (widget-show dialog))))
 417
 418
 419 ;; Entry
 420
 421 (define-simple-dialog create-entry (dialog "Entry")
 422   (let ((main (make-instance 'v-box
 423                :border-width 10 :spacing 10 :parent dialog)))
 424
 425     (let ((entry (make-instance 'entry :text "hello world" :parent main)))
 426       (editable-select-region entry 0 5) ; this has no effect when
 427                                          ; entry is editable
 428 ;;     (editable-insert-text entry "great " 6)
 429 ;;     (editable-delete-text entry 6 12)
 430
 431       (let ((combo (make-instance 'combo-box-entry
 432                     :parent main
 433                     :content '("item0"
 434                                "item1 item1"
 435                                "item2 item2 item2"
 436                                "item3 item3 item3 item3"
 437                                "item4 item4 item4 item4 item4"
 438                                "item5 item5 item5 item5 item5 item5"
 439                                "item6 item6 item6 item6 item6"
 440                                "item7 item7 item7 item7"
 441                                "item8 item8 item8"
 442                                "item9 item9"))))
 443         (with-slots (child) combo
 444           (setf (editable-text child) "hello world")
 445           (editable-select-region child 0)))
 446
 447       (flet ((create-check-button (label slot)
 448                (make-instance 'check-button
 449                 :label label :active t :parent main
 450                 :signal (list 'toggled
 451                               #'(lambda (button)
 452                                   (setf (slot-value entry slot)
 453                                         (toggle-button-active-p button)))
 454                               :object t))))
 455
 456         (create-check-button "Editable" 'editable)
 457         (create-check-button "Visible" 'visibility)
 458         (create-check-button "Sensitive" 'sensitive)))
 459     (widget-show-all main)))
 460
 461
 462 ;; Expander
 463
 464 (define-simple-dialog create-expander (dialog "Expander" :resizable nil)
 465   (make-instance 'v-box
 466    :parent dialog :spacing 5 :border-width 5 :show-all t
 467    :child (create-label "Expander demo. Click on the triangle for details.")
 468    :child (make-instance 'expander
 469            :label "Details"
 470            :child (create-label "Details can be shown or hidden."))))
 471
 472
 473 ;; File chooser dialog
 474
 475 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
 476   (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
 477   (dialog-add-button dialog "gtk-ok"
 478    #'(lambda ()
 479        (format t "Selected file: ~A~%" (file-chooser-filename dialog))
 480        (widget-destroy dialog))))
 481
 482
 483
 484 ;;; Handle box
 485
 486 ;; (defun create-handle-box-toolbar ()
 487 ;;   (let ((toolbar (toolbar-new :horizontal :both)))
 488 ;;     (toolbar-append-item
 489 ;;      toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
 490 ;;      :tooltip-text "Horizontal toolbar layout"
 491 ;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
 492
 493 ;;     (toolbar-append-item
 494 ;;      toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
 495 ;;      :tooltip-text "Vertical toolbar layout"
 496 ;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
 497
 498 ;;     (toolbar-append-space toolbar)
 499
 500 ;;     (toolbar-append-item
 501 ;;      toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
 502 ;;      :tooltip-text "Only show toolbar icons"
 503 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
 504
 505 ;;     (toolbar-append-item
 506 ;;      toolbar "Text" (pixmap-new "clg:examples;test.xpm")
 507 ;;      :tooltip-text "Only show toolbar text"
 508 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
 509
 510 ;;     (toolbar-append-item
 511 ;;      toolbar "Both" (pixmap-new "clg:examples;test.xpm")
 512 ;;      :tooltip-text "Show toolbar icons and text"
 513 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
 514
 515 ;;     (toolbar-append-space toolbar)
 516
 517 ;;     (toolbar-append-item
 518 ;;      toolbar "Small" (pixmap-new "clg:examples;test.xpm")
 519 ;;      :tooltip-text "Use small spaces"
 520 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
 521
 522 ;;     (toolbar-append-item
 523 ;;      toolbar "Big" (pixmap-new "clg:examples;test.xpm")
 524 ;;      :tooltip-text "Use big spaces"
 525 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
 526
 527 ;;     (toolbar-append-space toolbar)
 528
 529 ;;     (toolbar-append-item
 530 ;;      toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
 531 ;;      :tooltip-text "Enable tooltips"
 532 ;;      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
 533
 534 ;;     (toolbar-append-item
 535 ;;      toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
 536 ;;      :tooltip-text "Disable tooltips"
 537 ;;      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
 538
 539 ;;     (toolbar-append-space toolbar)
 540
 541 ;;     (toolbar-append-item
 542 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
 543 ;;      :tooltip-text "Show borders"
 544 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
 545
 546 ;;     (toolbar-append-item
 547 ;;      toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
 548 ;;      :tooltip-text "Hide borders"
 549 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
 550
 551 ;;     toolbar))
 552
 553
 554 ;; (defun handle-box-child-signal (handle-box child action)
 555 ;;   (format t "~S: child ~S ~A~%" handle-box child action))
 556
 557
 558 ;; (define-test-window create-handle-box "Handle Box Test"
 559 ;;   (setf (window-allow-grow-p window) t)
 560 ;;   (setf (window-allow-shrink-p window) t)
 561 ;;   (setf (window-auto-shrink-p window) nil)
 562 ;;   (setf (container-border-width window) 20)
 563 ;;   (let ((v-box (v-box-new nil 0)))
 564 ;;     (container-add window v-box)
 565
 566 ;;     (container-add v-box (create-label "Above"))
 567 ;;     (container-add v-box (hseparator-new))
 568
 569 ;;     (let ((hbox (hbox-new nil 10)))
 570 ;;       (container-add v-box hbox)
 571
 572 ;;       (let ((handle-box (handle-box-new)))
 573 ;;      (box-pack-start hbox handle-box nil nil 0)
 574 ;;      (signal-connect
 575 ;;       handle-box 'child-attached
 576 ;;       #'(lambda (child)
 577 ;;           (handle-box-child-signal handle-box child "attached")))
 578 ;;      (signal-connect
 579 ;;       handle-box 'child-detached
 580 ;;       #'(lambda (child)
 581 ;;           (handle-box-child-signal handle-box child "detached")))
 582 ;;      (container-add handle-box (create-handle-box-toolbar)))
 583
 584 ;;       (let ((handle-box (handle-box-new)))
 585 ;;      (box-pack-start hbox handle-box nil nil 0)
 586 ;;      (signal-connect
 587 ;;       handle-box 'child-attached
 588 ;;       #'(lambda (child)
 589 ;;           (handle-box-child-signal handle-box child "attached")))
 590 ;;      (signal-connect
 591 ;;       handle-box 'child-detached
 592 ;;       #'(lambda (child)
 593 ;;           (handle-box-child-signal handle-box child "detached")))
 594
 595 ;;      (let ((handle-box2 (handle-box-new)))
 596 ;;        (container-add handle-box handle-box2)
 597 ;;        (signal-connect
 598 ;;         handle-box2 'child-attached
 599 ;;         #'(lambda (child)
 600 ;;             (handle-box-child-signal handle-box child "attached")))
 601 ;;        (signal-connect
 602 ;;         handle-box2 'child-detached
 603 ;;         #'(lambda (child)
 604 ;;             (handle-box-child-signal handle-box child "detached")))
 605 ;;        (container-add handle-box2 (create-label "Foo!")))))
 606
 607 ;;     (container-add v-box (hseparator-new))
 608 ;;     (container-add v-box (create-label "Below"))))
 609
 610 ;;; Image
 611
 612 (define-toplevel create-image (window "Image")
 613   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 614
 615
 616 ;;; Labels
 617
 618 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 619   (flet ((create-label-in-frame (frame-label label-text &rest args)
 620            (list
 621             (make-instance 'frame
 622              :label frame-label
 623              :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
 624             :fill nil :expand nil)))
 625     (make-instance 'h-box
 626      :spacing 5 :parent window
 627      :child-args '(:fill nil :expand nil)
 628      :child (make-instance 'v-box
 629              :spacing 5
 630              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 631              :child (create-label-in-frame "Multi-line Label"
 632 "This is a Multi-line label.
 633 Second line
 634 Third line")
 635              :child (create-label-in-frame "Left Justified Label"
 636 "This is a Left-Justified
 637 Multi-line.
 638 Third line"
 639                       :justify :left)
 640              :child (create-label-in-frame "Right Justified Label"
 641 "This is a Right-Justified
 642 Multi-line.
 643 Third line"
 644                      :justify :right))
 645      :child (make-instance 'v-box
 646              :spacing 5
 647              :child (create-label-in-frame "Line wrapped label"
 648 "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.
 649      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 650                       :wrap t)
 651
 652              :child (create-label-in-frame "Filled, wrapped label"
 653 "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.
 654     This is a new paragraph.
 655     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 656                       :justify :fill :wrap t)
 657
 658              :child (create-label-in-frame "Underlined label"
 659 "This label is underlined!
 660 This one is underlined (こんにちは) in quite a funky fashion"
 661                       :justify :left
 662                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 663
 664
 665 ;;; Layout
 666
 667 ;; (defun layout-expose (layout event)
 668 ;;   (with-slots (window x-offset y-offset) layout
 669 ;;     (with-slots (x y width height) event
 670 ;;       (let ((imin (truncate (+ x-offset x) 10))
 671 ;;          (imax (truncate (+ x-offset x width 9) 10))
 672 ;;          (jmin (truncate (+ y-offset y) 10))
 673 ;;          (jmax (truncate (+ y-offset y height 9) 10)))
 674 ;;      (declare (fixnum imin imax jmin jmax))
 675 ;;      (gdk:window-clear-area window x y width height)
 676
 677 ;;      (let ((window (layout-bin-window layout))
 678 ;;            (gc (style-get-gc (widget-style layout) :black)))
 679 ;;        (do ((i imin (1+ i)))
 680 ;;            ((= i imax))
 681 ;;          (declare (fixnum i))
 682 ;;          (do ((j jmin (1+ j)))
 683 ;;              ((= j jmax))
 684 ;;            (declare (fixnum j))
 685 ;;            (unless (zerop (mod (+ i j) 2))
 686 ;;              (gdk:draw-rectangle
 687 ;;               window gc t
 688 ;;               (- (* 10 i) x-offset) (- (* 10 j) y-offset)
 689 ;;               (1+ (mod i 10)) (1+ (mod j 10))))))))))
 690 ;;   t)
 691
 692
 693 (define-toplevel create-layout (window "Layout" :default-width 200
 694                                                 :default-height 200)
 695   (let ((layout (make-instance 'layout
 696                  :parent (make-instance 'scrolled-window :parent window)
 697                  :width 1600 :height 128000 :events '(:exposure-mask)
 698 ;;               :signal (list 'expose-event #'layout-expose :object t)
 699                  )))
 700
 701     (with-slots (hadjustment vadjustment) layout
 702       (setf
 703        (adjustment-step-increment hadjustment) 10.0
 704        (adjustment-step-increment vadjustment) 10.0))
 705
 706     (dotimes (i 16)
 707       (dotimes (j 16)
 708         (let ((text (format nil "Button ~D, ~D" i j)))
 709           (make-instance (if (not (zerop (mod (+ i j) 2)))
 710                              'button
 711                            'label)
 712            :label text :parent (list layout :x (* j 100) :y (* i 100))))))
 713
 714     (loop
 715      for i from 16 below 1280
 716      do (let ((text (format nil "Button ~D, ~D" i 0)))
 717           (make-instance (if (not (zerop (mod i 2)))
 718                              'button
 719                            'label)
 720            :label text :parent (list layout :x 0 :y (* 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 int 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 :show-all t
 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                 (radio-menu-item-add-to-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             (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
 839       menu)))
 840
 841
 842 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 843   (let* ((main (make-instance 'v-box :parent dialog))
 844 ;        (accel-group (make-instance 'accel-group))
 845          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 846 ;    (accel-group-attach accel-group window)
 847
 848     (let ((menu-item (make-instance 'menu-item
 849                       :label (format nil "test~%line2"))))
 850       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 851       (menu-shell-append menubar menu-item))
 852
 853     (let ((menu-item (make-instance 'menu-item :label "foo")))
 854       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 855       (menu-shell-append menubar menu-item))
 856
 857     (let ((menu-item (make-instance 'menu-item :label "bar")))
 858       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 859       (setf (menu-item-right-justified-p menu-item) t)
 860       (menu-shell-append menubar menu-item))
 861
 862     (make-instance 'v-box
 863      :spacing 10 :border-width 10 :parent main
 864      :child (make-instance 'combo-box
 865              :active 3
 866              :content (loop
 867                        for i from 1 to 5
 868                        collect (format nil "Item ~D" i))))
 869
 870     (widget-show-all main)))
 871
 872
 873 ;;; Notebook
 874
 875 (defun create-notebook-page (notebook page-num)
 876   (let* ((title (format nil "Page ~D" page-num))
 877          (page (make-instance 'frame :label title :border-width 10))
 878          (v-box (make-instance 'v-box
 879                  :homogeneous t :border-width 10 :parent page)))
 880
 881     (make-instance 'h-box
 882      :parent (list v-box :fill nil :padding 5) :homogeneous t
 883      :child-args '(:padding 5)
 884      :child (make-instance 'check-button
 885              :label "Fill Tab" :active t
 886              :signal (list 'toggled
 887                            #'(lambda (button)
 888                                (setf
 889                                 (notebook-child-tab-fill-p page)
 890                                 (toggle-button-active-p button)))
 891                            :object t))
 892      :child (make-instance 'check-button
 893              :label "Expand Tab"
 894              :signal (list 'toggled
 895                            #'(lambda (button)
 896                                (setf
 897                                 (notebook-child-tab-expand-p page)
 898                                 (toggle-button-active-p button)))
 899                            :object t))
 900      :child (make-instance 'check-button
 901              :label "Pack end"
 902              :signal (list 'toggled
 903                            #'(lambda (button)
 904                                (setf
 905                                 (notebook-child-tab-pack page)
 906                                 (if (toggle-button-active-p button)
 907                                     :end
 908                                   :start)))
 909                            :object t))
 910      :child (make-instance 'button
 911              :label "Hide page"
 912              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 913
 914     (let ((label-box (make-instance 'h-box
 915                       :show-all t
 916                       :child-args '(:expand nil)
 917                       :child (make-instance 'image :pixmap book-closed-xpm)
 918                       :child (make-instance 'label :label title)))
 919           (menu-box (make-instance 'h-box
 920                      :show-all t
 921                      :child-args '(:expand nil)
 922                      :child (make-instance 'image :pixmap book-closed-xpm)
 923                      :child (make-instance 'label :label title))))
 924
 925       (widget-show-all page)
 926       (notebook-append notebook page label-box menu-box))))
 927
 928
 929 (define-simple-dialog create-notebook (dialog "Notebook")
 930   (let ((main (make-instance 'v-box :parent dialog)))
 931     (let ((notebook (make-instance 'notebook
 932                      :border-width 10 :tab-pos :top :parent main)))
 933       (flet ((set-image (page func xpm)
 934                (image-set-from-pixmap-data
 935                 (first (container-children (funcall func notebook page)))
 936                 xpm)))
 937         (signal-connect notebook 'switch-page
 938          #'(lambda (pointer page)
 939              (declare (ignore pointer))
 940              (unless (eq page (notebook-current-page-num notebook))
 941                (set-image page #'notebook-menu-label book-open-xpm)
 942                (set-image page #'notebook-tab-label book-open-xpm)
 943
 944                (let ((curpage (notebook-current-page notebook)))
 945                  (when curpage
 946                    (set-image curpage #'notebook-menu-label book-closed-xpm)
 947                    (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
 948       (loop for i from 1 to 5 do (create-notebook-page notebook i))
 949
 950       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 951
 952       (make-instance 'h-box
 953        :spacing 5 :border-width 10
 954        :parent (list main :expand nil)
 955        :child-args '(:fill nil)
 956        :child (make-instance 'check-button
 957                :label "Popup menu"
 958                :signal (list 'clicked
 959                         #'(lambda (button)
 960                             (if (toggle-button-active-p button)
 961                                 (notebook-popup-enable notebook)
 962                                 (notebook-popup-disable notebook)))
 963                         :object t))
 964        :child (make-instance 'check-button
 965                :label "Homogeneous tabs"
 966                :signal (list 'clicked
 967                         #'(lambda (button)
 968                             (setf
 969                              (notebook-homogeneous-p notebook)
 970                              (toggle-button-active-p button)))
 971                         :object t)))
 972
 973       (make-instance 'h-box
 974        :spacing 5 :border-width 10
 975        :parent (list main :expand nil)
 976        :child-args '(:expand nil)
 977        :child (make-instance 'label :label "Notebook Style: ")
 978        :child (let ((scrollable-p nil))
 979                 ;; option menu is deprecated, we should use combo-box
 980                 (make-instance 'combo-box
 981                  :content '("Standard" "No tabs" "Scrollable") :active 0
 982                  :signal (list 'changed
 983                           #'(lambda (combo-box)
 984                               (case (combo-box-active combo-box)
 985                                 (0
 986                                  (setf (notebook-show-tabs-p notebook) t)
 987                                  (when scrollable-p
 988                                    (setq scrollable-p nil)
 989                                    (setf (notebook-scrollable-p notebook) nil)
 990                                    (loop repeat 10
 991                                     do (notebook-remove-page notebook 5))))
 992                                 (1
 993                                  (setf (notebook-show-tabs-p notebook) nil)
 994                                  (when scrollable-p
 995                                    (setq scrollable-p nil)
 996                                    (setf (notebook-scrollable-p notebook) nil)
 997                                    (loop repeat 10
 998                                      do (notebook-remove-page notebook 5))))
 999                                 (2
1000                                  (unless scrollable-p
1001                                    (setq scrollable-p t)
1002                                    (setf (notebook-show-tabs-p notebook) t)
1003                                    (setf (notebook-scrollable-p notebook) t)
1004                                    (loop for i from 6 to 15
1005                                     do (create-notebook-page notebook i))))))
1006                           :object t)))
1007        :child (make-instance 'button
1008                :label "Show all Pages"
1009                :signal (list 'clicked
1010                         #'(lambda ()
1011                             (map-container nil #'widget-show notebook)))))
1012
1013       (make-instance 'h-box
1014        :spacing 5 :border-width 10
1015        :parent (list main :expand nil)
1016        :child (make-instance 'button
1017                :label "prev"
1018                :signal (list 'clicked #'notebook-prev-page :object notebook))
1019        :child (make-instance 'button
1020                :label "next"
1021                :signal (list 'clicked #'notebook-next-page :object notebook))
1022        :child (make-instance 'button
1023                :label "rotate"
1024                :signal (let ((tab-pos 0))
1025                          (list 'clicked
1026                           #'(lambda ()
1027                               (setq tab-pos (mod (1+ tab-pos) 4))
1028                               (setf
1029                                (notebook-tab-pos notebook)
1030                                (svref #(:top :right :bottom :left) tab-pos))))))))
1031     (widget-show-all main)))
1032
1033
1034 ;;; Panes
1035
1036 (defun toggle-resize (child)
1037   (let* ((paned (widget-parent child))
1038          (is-child1-p (eq child (paned-child1 paned))))
1039     (multiple-value-bind (child resize shrink)
1040         (if is-child1-p
1041             (paned-child1 paned)
1042           (paned-child2 paned))
1043       (container-remove paned child)
1044       (if is-child1-p
1045           (paned-pack1 paned child (not resize) shrink)
1046         (paned-pack2 paned child (not resize) shrink)))))
1047
1048 (defun toggle-shrink (child)
1049   (let* ((paned (widget-parent child))
1050          (is-child1-p (eq child (paned-child1 paned))))
1051     (multiple-value-bind (child resize shrink)
1052         (if is-child1-p
1053             (paned-child1 paned)
1054           (paned-child2 paned))
1055       (container-remove paned child)
1056       (if is-child1-p
1057           (paned-pack1 paned child resize (not shrink))
1058         (paned-pack2 paned child resize (not shrink))))))
1059
1060 (defun create-pane-options (paned frame-label label1 label2)
1061   (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
1062          (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
1063                                       :parent frame)))
1064
1065     (table-attach table (create-label label1) 0 1 0 1)
1066     (let ((check-button (make-instance 'check-button :label "Resize")))
1067       (table-attach table check-button 0 1 1 2)
1068       (signal-connect
1069        check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1070     (let ((check-button (make-instance 'check-button :label "Shrink")))
1071       (table-attach table check-button 0 1 2 3)
1072       (setf (toggle-button-active-p check-button) t)
1073       (signal-connect
1074        check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1075
1076     (table-attach table (create-label label2) 1 2 0 1)
1077     (let ((check-button (make-instance 'check-button :label "Resize")))
1078       (table-attach table check-button 1 2 1 2)
1079       (setf (toggle-button-active-p check-button) t)
1080       (signal-connect
1081        check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1082     (let ((check-button (make-instance 'check-button :label "Shrink")))
1083       (table-attach table check-button 1 2 2 3)
1084       (setf (toggle-button-active-p check-button) t)
1085       (signal-connect
1086        check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1087     frame))
1088
1089 (define-toplevel create-panes (window "Panes")
1090   (let* ((hpaned (make-instance 'h-paned
1091                   :child1 (make-instance 'frame
1092                            :width-request 60 :height-request 60
1093                            :shadow-type :in
1094                            :child (make-instance 'buttun :label "Hi there"))
1095                   :child2 (make-instance 'frame
1096                            :width-request 80 :height-request 60
1097                            :shadow-type :in)))
1098          (vpaned (make-instance 'v-paned
1099                   :border-width 5
1100                   :child1 hpaned
1101                   :child2 (make-instance 'frame
1102                            :width-request 80 :height-request 60
1103                            :shadow-type :in))))
1104
1105     (make-instance 'v-box
1106      :parent window
1107      :child-args '(:expand nil)
1108      :child (list vpaned :expand t)
1109      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1110      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1111
1112
1113 ;;; Progress bar
1114
1115
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 :show-all t
1123    :children (create-radio-button-group '("button1" "button2" "button3") 1)))
1124
1125
1126 ;;; Rangle controls
1127
1128 (define-simple-dialog create-range-controls (dialog "Range controls")
1129   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1130     (make-instance 'v-box
1131      :parent dialog :border-width 10 :spacing 10 :show-all t
1132      :child (make-instance 'h-scale
1133              :width-request 150 :adjustment adjustment :inverted t
1134              :update-policy :delayed :digits 1 :draw-value t)
1135      :child (make-instance 'h-scrollbar
1136              :adjustment adjustment :update-policy :continuous))))
1137
1138
1139 ;;; Reparent test
1140
1141 (define-simple-dialog create-reparent (dialog "Reparent")
1142   (let ((main (make-instance 'h-box
1143                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1144         (label (make-instance 'label :label "Hellow World")))
1145
1146     (flet ((create-frame (title)
1147              (let* ((frame (make-instance 'frame :label title :parent main))
1148                     (box (make-instance 'v-box
1149                           :spacing 5 :border-width 5 :parent frame))
1150                     (button (make-instance 'button
1151                              :label "switch" :parent (list box :expand nil))))
1152                (signal-connect button 'clicked
1153                 #'(lambda ()
1154                     (widget-reparent label box)))
1155                box)))
1156
1157       (box-pack-start (create-frame "Frame 1") label nil t 0)
1158       (create-frame "Frame 2"))
1159     (widget-show-all main)))
1160
1161
1162 ;;; Rulers
1163
1164 (define-toplevel create-rulers (window "Rulers"
1165                                 :default-width 300 :default-height 300
1166 ;;                              :events '(:pointer-motion-mask
1167 ;;                                        :pointer-motion-hint-mask)
1168                                 )
1169   (setf
1170    (widget-events window)
1171    '(:pointer-motion-mask :pointer-motion-hint-mask))
1172
1173   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
1174     (let ((ruler (make-instance 'h-ruler
1175                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1176                   :position 0.0d0 :max-size 20.0d0)))
1177       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1178       (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
1179     (let ((ruler (make-instance 'v-ruler
1180                   :lower 5.0d0 :upper 15.0d0
1181                   :position 0.0d0 :max-size 20.0d0)))
1182       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1183       (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
1184
1185
1186
1187 ;;; Scrolled window
1188
1189 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1190                                                       :default-width 300
1191                                                       :default-height 300)
1192   (let* ((scrolled-window
1193           (make-instance 'scrolled-window
1194            :parent dialog :border-width 10
1195            :vscrollbar-policy :automatic
1196            :hscrollbar-policy :automatic))
1197          (table
1198           (make-instance 'table
1199            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1200            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1201            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1202
1203       (scrolled-window-add-with-viewport scrolled-window table)
1204       (dotimes (i 20)
1205         (dotimes (j 20)
1206           (let ((button
1207                  (make-instance 'toggle-button
1208                   :label (format nil "button (~D,~D)~%" i j))))
1209             (table-attach table button i (1+ i) j (1+ j)))))
1210       (widget-show-all scrolled-window)))
1211
1212
1213 ;;; Shapes
1214
1215 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1216 ;;   (let* ((window
1217 ;;        (make-instance 'window
1218 ;;         :type type :x x :y y
1219 ;;         :events '(:button-motion :pointer-motion-hint :button-press)))
1220 ;;       (fixed
1221 ;;        (make-instance 'fixed
1222 ;;         :parent window :width 100 :height 100)))
1223
1224 ;;     (widget-realize window)
1225 ;;     (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1226 ;;       (let ((pixmap (pixmap-new source mask))
1227 ;;          (x-offset 0)
1228 ;;          (y-offset 0))
1229 ;;      (declare (fixnum x-offset y-offset))
1230 ;;      (fixed-put fixed pixmap px py)
1231 ;;      (widget-shape-combine-mask window mask px py)
1232
1233 ;;      (signal-connect window 'button-press-event
1234 ;;       #'(lambda (event)
1235 ;;           (when (typep event 'gdk:button-press-event)
1236 ;;             (setq x-offset (truncate (gdk:event-x event)))
1237 ;;             (setq y-offset (truncate (gdk:event-y event)))
1238 ;;             (grab-add window)
1239 ;;             (gdk:pointer-grab
1240 ;;              (widget-window window) t
1241 ;;              '(:button-release :button-motion :pointer-motion-hint)
1242 ;;              nil nil 0))
1243 ;;           t))
1244
1245 ;;      (signal-connect window 'button-release-event
1246 ;;       #'(lambda (event)
1247 ;;           (declare (ignore event))
1248 ;;           (grab-remove window)
1249 ;;           (gdk:pointer-ungrab 0)
1250 ;;           t))
1251
1252 ;;      (signal-connect window 'motion-notify-event
1253 ;;       #'(lambda (event)
1254 ;;           (declare (ignore event))
1255 ;;           (multiple-value-bind (win xp yp mask)
1256 ;;               (gdk:window-get-pointer root-window)
1257 ;;             (declare (ignore mask win) (fixnum xp yp))
1258 ;;             (widget-set-uposition
1259 ;;              window :x (- xp x-offset) :y (- yp y-offset)))
1260 ;;           t))
1261 ;;      (signal-connect window 'destroy destroy)))
1262
1263 ;;     (widget-show-all window)
1264 ;;     window))
1265
1266
1267 ;; (let ((modeller nil)
1268 ;;       (sheets nil)
1269 ;;       (rings nil))
1270 ;;   (defun create-shapes ()
1271 ;;     (let ((root-window (gdk:get-root-window)))
1272 ;;       (if (not modeller)
1273 ;;        (setq
1274 ;;         modeller
1275 ;;         (shape-create-icon
1276 ;;          "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1277 ;;          #'(lambda () (widget-destroyed modeller))))
1278 ;;      (widget-destroy modeller))
1279
1280 ;;       (if (not sheets)
1281 ;;        (setq
1282 ;;         sheets
1283 ;;         (shape-create-icon
1284 ;;          "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1285 ;;          #'(lambda () (widget-destroyed sheets))))
1286 ;;      (widget-destroy sheets))
1287
1288 ;;       (if (not rings)
1289 ;;        (setq
1290 ;;         rings
1291 ;;         (shape-create-icon
1292 ;;          "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1293 ;;          #'(lambda () (widget-destroyed rings))))
1294 ;;      (widget-destroy rings)))))
1295
1296
1297
1298 ;;; Spin buttons
1299
1300 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1301   (let ((main (make-instance 'v-box
1302                :spacing 5 :border-width 10 :parent dialog)))
1303
1304     (flet ((create-date-spinner (label adjustment shadow-type)
1305              (declare (ignore shadow-type))
1306              (make-instance 'v-box
1307               :child-args '(:expand nil)
1308               :child (make-instance 'label
1309                       :label label :xalign 0.0 :yalign 0.5)
1310               :child (make-instance 'spin-button
1311                       :adjustment adjustment :wrap t))))
1312       (make-instance 'frame
1313        :label "Not accelerated" :parent main
1314        :child (make-instance 'h-box
1315                :border-width 10
1316                :child-args '(:padding 5)
1317                :child (create-date-spinner "Day : "
1318                        (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1319                :child (create-date-spinner "Month : "
1320                        (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1321                :child (create-date-spinner "Year : "
1322                        (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1323
1324     (let ((spinner1 (make-instance 'spin-button
1325                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1326                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1327           (spinner2 (make-instance 'spin-button
1328                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1329                      :climb-rate 1.0 :wrap t))
1330           (value-label (make-instance 'label :label "0")))
1331       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1332        #'(lambda ()
1333            (setf
1334             (spin-button-digits spinner1)
1335             (floor (spin-button-value spinner2)))))
1336
1337       (make-instance 'frame
1338        :label "Accelerated" :parent main
1339        :child (make-instance 'v-box
1340                :border-width 5
1341                :child (list
1342                        (make-instance 'h-box
1343                         :child-args '(:padding 5)
1344                         :child (make-instance 'v-box
1345                                 :child (make-instance 'label
1346                                         :label "Value :"
1347                                         :xalign 0.0 :yalign 0.5)
1348                                 :child spinner1)
1349                         :child (make-instance 'v-box
1350                                 :child (make-instance 'label
1351                                         :label "Digits :"
1352                                         :xalign 0.0 :yalign 0.5)
1353                                 :child spinner2))
1354                        :expand nil :padding 5)
1355                :child (make-instance 'check-button
1356                        :label "Snap to 0.5-ticks" :active t
1357                        :signal (list 'clicked
1358                                 #'(lambda (button)
1359                                     (setf
1360                                      (spin-button-snap-to-ticks-p spinner1)
1361                                      (toggle-button-active-p button)))
1362                                 :object t))
1363                :child (make-instance 'check-button
1364                        :label "Numeric only input mode" :active t
1365                        :signal (list 'clicked
1366                                 #'(lambda (button)
1367                                     (setf
1368                                      (spin-button-numeric-p spinner1)
1369                                      (toggle-button-active-p button)))
1370                                 :object t))
1371                :child value-label
1372                :child (list
1373                        (make-instance 'h-box
1374                         :child-args '(:padding 5)
1375                         :child (make-instance 'button
1376                                 :label "Value as Int"
1377                                 :signal (list 'clicked
1378                                          #'(lambda ()
1379                                              (setf
1380                                               (label-label value-label)
1381                                               (format nil "~D"
1382                                                (spin-button-value-as-int
1383                                                 spinner1))))))
1384                         :child (make-instance 'button
1385                                 :label "Value as Float"
1386                                 :signal (list 'clicked
1387                                          #'(lambda ()
1388                                              (setf
1389                                               (label-label value-label)
1390                                               (format nil
1391                                                (format nil "~~,~DF"
1392                                                 (spin-button-digits spinner1))
1393                                                (spin-button-value spinner1)))))))
1394                        :padding 5 :expand nil))))
1395     (widget-show-all main)))
1396
1397
1398 ;;; Statusbar
1399
1400 (define-toplevel create-statusbar (window "Statusbar")
1401   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1402         (close-button (create-button '("close" :can-default t)
1403                        #'widget-destroy :object window))
1404         (counter 0))
1405
1406     (signal-connect statusbar 'text-popped
1407      #'(lambda (context-id text)
1408          (declare (ignore context-id))
1409          (format nil "Popped: ~A~%" text)))
1410
1411     (make-instance 'v-box
1412      :parent window
1413      :child (make-instance 'v-box
1414              :border-width 10 :spacing 10
1415              :child (create-button "push something"
1416                      #'(lambda ()
1417                          (statusbar-push statusbar 1
1418                           (format nil "something ~D" (incf counter)))))
1419              :child (create-button "pop"
1420                      #'(lambda ()
1421                          (statusbar-pop statusbar 1)))
1422              :child (create-button "steal #4"
1423                      #'(lambda ()
1424                          (statusbar-remove statusbar 1 4)))
1425              :child (create-button "dump stack")
1426              :child (create-button "test contexts"))
1427      :child (list (make-instance 'h-separator) :expand nil)
1428      :child (list
1429              (make-instance 'v-box :border-width 10 :child close-button)
1430              :expand nil)
1431      :child (list statusbar :expand nil))
1432
1433     (widget-grab-focus close-button)))
1434
1435
1436 ;;; Idle test
1437
1438 (define-simple-dialog create-idle-test (dialog "Idle Test")
1439   (let ((label (make-instance 'label
1440                 :label "count: 0" :xpad 10 :ypad 10))
1441         (idle nil)
1442         (count 0))
1443     (signal-connect dialog 'destroy
1444      #'(lambda () (when idle (idle-remove idle))))
1445
1446     (make-instance 'v-box
1447      :parent dialog :border-width 10 :spacing 10 :show-all t
1448      :child label
1449      :child (make-instance 'frame
1450              :label "Label Container" :border-width 5
1451              :child(make-instance 'v-box
1452                    :children (create-radio-button-group
1453                               '(("Resize-Parent" :parent)
1454                                 ("Resize-Queue" :queue)
1455                                 ("Resize-Immediate" :immediate))
1456                               0
1457                               #'(lambda (mode)
1458                                   (setf
1459                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1460
1461     (dialog-add-button dialog "Start"
1462      #'(lambda ()
1463          (unless idle
1464            (setq idle
1465             (idle-add
1466              #'(lambda ()
1467                  (incf count)
1468                  (setf (label-label label) (format nil "count: ~D" count))
1469                  t))))))
1470
1471     (dialog-add-button dialog "Stop"
1472      #'(lambda ()
1473          (when idle
1474            (idle-remove idle)
1475            (setq idle nil))))))
1476
1477
1478
1479 ;;; Timeout test
1480
1481 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1482   (let ((label (make-instance 'label
1483                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1484         (timer nil)
1485         (count 0))
1486     (signal-connect dialog 'destroy
1487      #'(lambda () (when timer (timeout-remove timer))))
1488
1489     (dialog-add-button dialog "Start"
1490      #'(lambda ()
1491          (unless timer
1492            (setq timer
1493             (timeout-add 100
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 timer
1502            (timeout-remove timer)
1503            (setq timer nil))))))
1504
1505
1506 ;;; Text
1507
1508 (define-simple-dialog create-text (dialog "Text" :default-width 400
1509                                                  :default-height 400)
1510   (make-instance 'text-view :border-width 10  :parent dialog :visible t))
1511
1512 ;;; Toggle buttons
1513
1514 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1515   (make-instance 'v-box
1516    :border-width 10 :spacing 10 :parent dialog :show-all t
1517       :children (loop
1518               for n from 1 to 3
1519               collect (make-instance 'toggle-button
1520                        :label (format nil "Button~D" (1+ n))))))
1521
1522
1523
1524 ;;; Toolbar test
1525
1526 ;; TODO: style properties
1527 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1528   (let ((toolbar (make-instance 'toolbar :parent window)))
1529 ;    (setf (toolbar-relief toolbar) :none)
1530
1531     ;; Insert a stock item
1532     (toolbar-append toolbar "gtk-quit"
1533      :tooltip-text "Destroy toolbar"
1534      :tooltip-private-text "Toolbar/Quit"
1535      :callback #'(lambda () (widget-destroy window)))
1536
1537     ;; Image widge as icon
1538     (toolbar-append toolbar "Horizontal"
1539      :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1540      :tooltip-text "Horizontal toolbar layout"
1541      :tooltip-private-text "Toolbar/Horizontal"
1542      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1543
1544     ;; Icon from file
1545     (toolbar-append toolbar "Vertical"
1546      :icon #p"clg:examples;test.xpm"
1547      :tooltip-text "Vertical toolbar layout"
1548      :tooltip-private-text "Toolbar/Vertical"
1549      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1550
1551     (toolbar-append toolbar :space)
1552
1553     ;; Stock icon
1554     (toolbar-append toolbar "Icons"
1555      :icon "gtk-execute"
1556      :tooltip-text "Only show toolbar icons"
1557      :tooltip-private-text "Toolbar/IconsOnly"
1558      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1559
1560     ;; Icon from pixmap data
1561     (toolbar-append toolbar "Text"
1562      :icon gtk-mini-xpm
1563      :tooltip-text "Only show toolbar text"
1564      :tooltip-private-text "Toolbar/TextOnly"
1565      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1566
1567     (toolbar-append toolbar "Both"
1568      :tooltip-text "Show toolbar icons and text"
1569      :tooltip-private-text "Toolbar/Both"
1570      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1571
1572     (toolbar-append toolbar :space)
1573
1574     (toolbar-append toolbar (make-instance 'entry)
1575      :tooltip-text "This is an unusable GtkEntry"
1576      :tooltip-private-text "Hey don't click me!")
1577
1578     (toolbar-append toolbar :space)
1579
1580 ;;     (toolbar-append-item
1581 ;;      toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1582 ;;      :tooltip-text "Use small spaces"
1583 ;;      :tooltip-private-text "Toolbar/Small"
1584 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1585
1586 ;;     (toolbar-append-item
1587 ;;      toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1588 ;;      :tooltip-text "Use big spaces"
1589 ;;      :tooltip-private-text "Toolbar/Big"
1590 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1591
1592 ;;     (toolbar-append toolbar :space)
1593
1594     (toolbar-append
1595      toolbar "Enable"
1596      :tooltip-text "Enable tooltips"
1597      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1598
1599     (toolbar-append
1600      toolbar "Disable"
1601      :tooltip-text "Disable tooltips"
1602      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1603
1604     (toolbar-append toolbar :space)
1605
1606 ;;     (toolbar-append-item
1607 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1608 ;;      :tooltip-text "Show borders"
1609 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1610
1611 ;;     (toolbar-append-item
1612 ;;      toolbar
1613 ;;      "Borderless" (pixmap-new "clg:examples;test.xpm")
1614 ;;      :tooltip-text "Hide borders"
1615 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1616
1617 ;;     (toolbar-append toolbar :space)
1618
1619 ;;     (toolbar-append-item
1620 ;;      toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1621 ;;      :tooltip-text "Empty spaces"
1622 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1623
1624 ;;     (toolbar-append-item
1625 ;;      toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1626 ;;      :tooltip-text "Lines in spaces"
1627 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1628
1629     ))
1630
1631
1632
1633 ;;; Tooltips test
1634
1635 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1636   (let ((tooltips (make-instance 'tooltips)))
1637     (flet ((create-button (label tip-text tip-private)
1638              (let ((button (make-instance 'toggle-button :label label)))
1639                (tooltips-set-tip tooltips button tip-text tip-private)
1640                button)))
1641       (make-instance 'v-box
1642        :parent dialog :border-width 10 :spacing 10 :show-all t
1643        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1644        :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")))
1645
1646     (let ((close-button (first (container-children (dialog-action-area dialog)))))
1647     (tooltips-set-tip tooltips close-button "Push this button to close window"
1648          "ContextHelp/buttons/Close"))))
1649
1650
1651 ;;; UI Manager
1652
1653 (defvar *ui-description*
1654   '((:menubar "MenuBar"
1655      (:menu "FileMenu"
1656       (:menuitem "New")
1657       (:menuitem "Open")
1658       (:menuitem "Save")
1659       (:menuitem "SaveAs")
1660       :separator
1661       (:menuitem "Quit"))
1662      (:menu "PreferencesMenu"
1663        (:menu "ColorMenu"
1664         (:menuitem "Red")
1665         (:menuitem "Green")
1666         (:menuitem "Blue"))
1667        (:menu "ShapeMenu"
1668         (:menuitem "Square")
1669         (:menuitem "Rectangle")
1670         (:menuitem "Oval"))
1671        (:menuitem "Bold"))
1672      (:menu "HelpMenu"
1673       (:menuitem "About")))
1674     (:toolbar "ToolBar"
1675      (:toolitem "Open")
1676      (:toolitem "Quit")
1677      (:separator "Sep1")
1678      (:toolitem "Logo"))))
1679
1680 (define-simple-dialog create-ui-manager (dialog "UI Manager")
1681   (let ((actions
1682          (make-instance 'action-group
1683           :name "Actions"
1684           :action (create-action "FileMenu" nil "_File")
1685           :action (create-action "PreferencesMenu" nil "_Preferences")
1686           :action (create-action "ColorMenu" nil "_Color")
1687           :action (create-action "ShapeMenu" nil "_Shape")
1688           :action (create-action "HelpMenu" nil "_Help")
1689           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1690           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
1691           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1692           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1693           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
1694           :action (create-action "About" nil "_About" "<control>A" "About")
1695           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1696           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1697           :actions (create-radio-actions
1698                     '(("Red" nil "_Red" "<control>R" "Blood")
1699                       ("Green" nil "_Green" "<control>G" "Grass")
1700                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1701                     "Green")
1702           :actions (create-radio-actions
1703                     '(("Square" nil "_Square" "<control>S" "Square")
1704                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1705                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1706         (ui (make-instance 'ui-manager)))
1707
1708     (ui-manager-insert-action-group ui actions)
1709     (ui-manager-add-ui ui *ui-description*)
1710
1711     (window-add-accel-group dialog (ui-manager-accel-group ui))
1712
1713     (make-instance 'v-box
1714      :parent dialog :show-all t
1715      :child (list
1716              (ui-manager-get-widget ui "/MenuBar")
1717              :expand nil :fill nil)
1718      :child (list
1719              (ui-manager-get-widget ui "/ToolBar")
1720              :expand nil :fill nil)
1721      :child (make-instance 'label
1722              :label "Type <alt> to start"
1723              :xalign 0.5 :yalign 0.5
1724              :width-request 200 :height-request 200))))
1725
1726
1727
1728 ;;; Main window
1729
1730 (defun create-main-window ()
1731 ;;   (rc-parse "clg:examples;testgtkrc2")
1732 ;;   (rc-parse "clg:examples;testgtkrc")
1733
1734   (let* ((button-specs
1735           '(("button box" create-button-box)
1736             ("buttons" create-buttons)
1737             ("calendar" create-calendar)
1738             ("check buttons" create-check-buttons)
1739             ("color selection" create-color-selection)
1740 ;;          ("cursors" #|create-cursors|#)
1741             ("dialog" create-dialog)
1742 ;; ;        ("dnd")
1743             ("entry" create-entry)
1744 ;;          ("event watcher")
1745             ("enxpander" create-expander)
1746             ("file chooser" create-file-chooser)
1747 ;;          ("font selection")
1748 ;;          ("handle box" create-handle-box)
1749             ("image" create-image)
1750 ;;          ("item factory")
1751             ("labels" create-labels)
1752             ("layout" create-layout)
1753             ("list" create-list)
1754             ("menus" create-menus)
1755 ;;          ("modal window")
1756             ("notebook" create-notebook)
1757             ("panes" create-panes)
1758 ;;          ("progress bar" #|create-progress-bar|#)
1759             ("radio buttons" create-radio-buttons)
1760             ("range controls" create-range-controls)
1761 ;;          ("rc file")
1762             ("reparent" create-reparent)
1763             ("rulers" create-rulers)
1764 ;;          ("saved position")
1765             ("scrolled windows" create-scrolled-windows)
1766 ;;          ("shapes" create-shapes)
1767             ("spinbutton" create-spins)
1768             ("statusbar" create-statusbar)
1769             ("test idle" create-idle-test)
1770 ;;          ("test mainloop")
1771 ;;          ("test scrolling")
1772 ;;          ("test selection")
1773             ("test timeout" create-timeout-test)
1774             ("text" create-text)
1775             ("toggle buttons" create-toggle-buttons)
1776             ("toolbar" create-toolbar)
1777             ("tooltips" create-tooltips)
1778 ;;          ("tree" #|create-tree|#)
1779             ("UI manager" create-ui-manager)
1780 ))
1781         (main-window (make-instance 'window
1782                       :title "testgtk.lisp" :name "main_window"
1783                       :default-width 200 :default-height 400
1784                       :allow-grow t :allow-shrink nil))
1785         (scrolled-window (make-instance 'scrolled-window
1786                           :hscrollbar-policy :automatic
1787                           :vscrollbar-policy :automatic
1788                           :border-width 10))
1789         (close-button (make-instance 'button
1790                        :label "close" :can-default t
1791                        :signal (list 'clicked #'widget-destroy
1792                                      :object main-window))))
1793
1794     ;; Main box
1795     (make-instance 'v-box
1796      :parent main-window
1797      :child-args '(:expand nil)
1798      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1799      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1800      :child (list scrolled-window :expand t)
1801      :child (make-instance 'h-separator)
1802      :child (make-instance 'v-box
1803              :homogeneous nil :spacing 10 :border-width 10
1804              :child close-button))
1805
1806     (let ((content-box
1807            (make-instance 'v-box
1808             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1809             :children (mapcar #'(lambda (spec)
1810                                   (apply #'create-button spec))
1811                               button-specs))))
1812       (scrolled-window-add-with-viewport scrolled-window content-box))
1813
1814     (widget-grab-focus close-button)
1815     (widget-show-all main-window)
1816     main-window))
1817
1818 (clg-init)
1819 (create-main-window)