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.4 2004-11-06 16:36:34 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     (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
  59     ,@body))
  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 "OK")
 188            :child (make-instance 'button :label "Cancel")
 189            :child (make-instance 'button :label "Help"))))
 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 (label-new "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
 432                     :parent main
 433                     :popdown-strings '("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 (entry) combo
 444           (setf (editable-text entry) "hello world")
 445           (editable-select-region entry 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
 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 (label-new "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 (label-new "Foo!")))))
 596
 597 ;;     (container-add v-box (hseparator-new))
 598 ;;     (container-add v-box (label-new "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 ;;   (with-slots (window x-offset y-offset) layout
 659 ;;     (with-slots (x y width height) event
 660 ;;       (let ((imin (truncate (+ x-offset x) 10))
 661 ;;          (imax (truncate (+ x-offset x width 9) 10))
 662 ;;          (jmin (truncate (+ y-offset y) 10))
 663 ;;          (jmax (truncate (+ y-offset y height 9) 10)))
 664 ;;      (declare (fixnum imin imax jmin jmax))
 665 ;;      (gdk:window-clear-area window x y width height)
 666
 667 ;;      (let ((window (layout-bin-window layout))
 668 ;;            (gc (style-get-gc (widget-style layout) :black)))
 669 ;;        (do ((i imin (1+ i)))
 670 ;;            ((= i imax))
 671 ;;          (declare (fixnum i))
 672 ;;          (do ((j jmin (1+ j)))
 673 ;;              ((= j jmax))
 674 ;;            (declare (fixnum j))
 675 ;;            (unless (zerop (mod (+ i j) 2))
 676 ;;              (gdk:draw-rectangle
 677 ;;               window gc t
 678 ;;               (- (* 10 i) x-offset) (- (* 10 j) y-offset)
 679 ;;               (1+ (mod i 10)) (1+ (mod j 10))))))))))
 680 ;;   t)
 681
 682
 683 (define-toplevel create-layout (window "Layout" :default-width 200
 684                                                 :default-height 200)
 685   (let ((layout (make-instance 'layout
 686                  :parent (make-instance 'scrolled-window :parent window)
 687                  :width 1600 :height 128000 :events '(:exposure-mask)
 688 ;;               :signal (list 'expose-event #'layout-expose :object t)
 689                  )))
 690
 691     (with-slots (hadjustment vadjustment) layout
 692       (setf
 693        (adjustment-step-increment hadjustment) 10.0
 694        (adjustment-step-increment vadjustment) 10.0))
 695
 696     (dotimes (i 16)
 697       (dotimes (j 16)
 698         (let ((text (format nil "Button ~D, ~D" i j)))
 699           (make-instance (if (not (zerop (mod (+ i j) 2)))
 700                              'button
 701                            'label)
 702            :label text :parent (list layout :x (* j 100) :y (* i 100))))))
 703
 704     (loop
 705      for i from 16 below 1280
 706      do (let ((text (format nil "Button ~D, ~D" i 0)))
 707           (make-instance (if (not (zerop (mod i 2)))
 708                              'button
 709                            'label)
 710            :label text :parent (list layout :x 0 :y (* i 100)))))))
 711
 712
 713
 714 ;;; List
 715
 716 ;; (define-standard-dialog create-list "List"
 717 ;;   (let ((scrolled-window (scrolled-window-new))
 718 ;;         (list (list-new)))
 719 ;;     (setf (container-border-width scrolled-window) 5)
 720 ;;     (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
 721 ;;     (box-pack-start main-box scrolled-window t t 0)
 722 ;;     (setf (widget-height scrolled-window) 300)
 723
 724 ;;     (setf (list-selection-mode list) :extended)
 725 ;;     (scrolled-window-add-with-viewport scrolled-window list)
 726 ;;     (setf
 727 ;;      (container-focus-vadjustment list)
 728 ;;      (scrolled-window-vadjustment scrolled-window))
 729 ;;     (setf
 730 ;;      (container-focus-hadjustment list)
 731 ;;      (scrolled-window-hadjustment scrolled-window))
 732
 733 ;;     (with-open-file (file "clg:examples;gtktypes.lisp")
 734 ;;       (labels ((read-file ()
 735 ;;               (let ((line (read-line file nil nil)))
 736 ;;                 (when line
 737 ;;                   (container-add list (list-item-new line))
 738 ;;                   (read-file)))))
 739 ;;      (read-file)))
 740
 741 ;;     (let ((hbox (hbox-new t 5)))
 742 ;;       (setf (container-border-width hbox) 5)
 743 ;;       (box-pack-start main-box hbox nil t 0)
 744
 745 ;;       (let ((button (button-new "Insert Row"))
 746 ;;          (i 0))
 747 ;;      (box-pack-start hbox button t t 0)
 748 ;;      (signal-connect
 749 ;;       button 'clicked
 750 ;;       #'(lambda ()
 751 ;;           (let ((item
 752 ;;                  (list-item-new (format nil "added item ~A" (incf i)))))
 753 ;;             (widget-show item)
 754 ;;             (container-add list item)))))
 755
 756 ;;       (let ((button (button-new "Clear List")))
 757 ;;      (box-pack-start hbox button t t 0)
 758 ;;      (signal-connect
 759 ;;       button 'clicked #'(lambda () (list-clear-items list 0 -1))))
 760
 761 ;;       (let ((button (button-new "Remove Selection")))
 762 ;;      (box-pack-start hbox button t t 0)
 763 ;;      (signal-connect
 764 ;;       button 'clicked
 765 ;;       #'(lambda ()
 766 ;;           (let ((selection (list-selection list)))
 767 ;;             (if (eq (list-selection-mode list) :extended)
 768 ;;                 (let ((item (or
 769 ;;                              (container-focus-child list)
 770 ;;                              (first selection))))
 771 ;;                   (when item
 772 ;;                     (let* ((children (container-children list))
 773 ;;                            (sel-row
 774 ;;                             (or
 775 ;;                              (find-if
 776 ;;                               #'(lambda (item)
 777 ;;                                   (eq (widget-state item) :selected))
 778 ;;                               (member item children))
 779 ;;                              (find-if
 780 ;;                               #'(lambda (item)
 781 ;;                                   (eq (widget-state item) :selected))
 782 ;;                               (member item (reverse children))))))
 783 ;;                       (list-remove-items list selection)
 784 ;;                       (when sel-row
 785 ;;                         (list-select-child list sel-row)))))
 786 ;;               (list-remove-items list selection)))))
 787 ;;      (box-pack-start hbox button t t 0)))
 788
 789 ;;     (let ((cbox (hbox-new nil 0)))
 790 ;;       (box-pack-start main-box cbox nil t 0)
 791
 792 ;;       (let ((hbox (hbox-new nil 5))
 793 ;;          (option-menu
 794 ;;           (create-option-menu
 795 ;;            `(("Single"
 796 ;;               ,#'(lambda () (setf (list-selection-mode list) :single)))
 797 ;;              ("Browse"
 798 ;;               ,#'(lambda () (setf (list-selection-mode list) :browse)))
 799 ;;              ("Multiple"
 800 ;;               ,#'(lambda () (setf (list-selection-mode list) :multiple)))
 801 ;;              ("Extended"
 802 ;;               ,#'(lambda () (setf (list-selection-mode list) :extended))))
 803 ;;            3)))
 804
 805 ;;      (setf (container-border-width hbox) 5)
 806 ;;      (box-pack-start cbox hbox t nil 0)
 807 ;;      (box-pack-start hbox (label-new "Selection Mode :") nil t 0)
 808 ;;      (box-pack-start hbox option-menu nil t 0)))))
 809
 810
 811
 812 ;; Menus
 813
 814 (defun create-menu (depth tearoff)
 815   (unless (zerop depth)
 816     (let ((menu (make-instance 'menu)))
 817       (when tearoff
 818         (let ((menu-item (make-instance 'tearoff-menu-item)))
 819           (menu-shell-append menu menu-item)))
 820       (let ((group nil))
 821         (dotimes (i 5)
 822           (let ((menu-item
 823                  (make-instance 'radio-menu-item
 824                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 825             (if group
 826                 (radio-menu-item-add-to-group menu-item group)
 827               (setq group menu-item))
 828             (unless (zerop (mod depth 2))
 829               (setf (check-menu-item-active-p menu-item) t))
 830             (menu-shell-append menu menu-item)
 831             (when (= i 3)
 832               (setf (widget-sensitive-p menu-item) nil))
 833             (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
 834       menu)))
 835
 836
 837 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 838   (let* ((main (make-instance 'v-box :parent dialog))
 839 ;        (accel-group (make-instance 'accel-group))
 840          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 841 ;    (accel-group-attach accel-group window)
 842
 843     (let ((menu-item (make-instance 'menu-item
 844                       :label (format nil "test~%line2"))))
 845       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 846       (menu-shell-append menubar menu-item))
 847
 848     (let ((menu-item (make-instance 'menu-item :label "foo")))
 849       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 850       (menu-shell-append menubar menu-item))
 851
 852     (let ((menu-item (make-instance 'menu-item :label "bar")))
 853       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 854       (setf (menu-item-right-justified-p menu-item) t)
 855       (menu-shell-append menubar menu-item))
 856
 857     (let ((box2 (make-instance 'v-box
 858                  :spacing 10 :border-width 10 :parent main))
 859           (menu (create-menu 1 nil)))
 860
 861 ;      (setf (menu-accel-group menu) accel-group)
 862
 863       (let ((menu-item (make-instance 'check-menu-item
 864                         :label "Accelerate Me")))
 865         (menu-shell-append menu menu-item)
 866 ;;         (widget-add-accelerator
 867 ;;          menu-item 'activate accel-group "F1" '() '(:visible :signal-visible))
 868         )
 869
 870       (let ((menu-item (make-instance 'check-menu-item
 871                         :label "Accelerator Locked")))
 872         (menu-shell-append menu menu-item)
 873 ;;         (widget-add-accelerator
 874 ;;          menu-item 'activate accel-group "F2" '() '(:visible :locked))
 875         )
 876
 877       (let ((menu-item (make-instance 'check-menu-item
 878                         :label "Accelerator Frozen")))
 879         (menu-shell-append menu menu-item)
 880 ;;         (widget-add-accelerator
 881 ;;          menu-item 'activate accel-group "F2" '() '(:visible))
 882 ;;         (widget-add-accelerator
 883 ;;          menu-item 'activate accel-group "F3" '() '(:visible))
 884 ;;         (widget-lock-accelerators menuitem)
 885         )
 886
 887     (make-instance 'option-menu :parent box2 :menu menu :history 3)
 888     (widget-show-all main))))
 889
 890
 891 ;;; Notebook
 892
 893 (defun create-notebook-page (notebook page-num)
 894   (let* ((title (format nil "Page ~D" page-num))
 895          (page (make-instance 'frame :label title :border-width 10))
 896          (v-box (make-instance 'v-box
 897                  :homogeneous t :border-width 10 :parent page)))
 898
 899     (make-instance 'h-box
 900      :parent (list v-box :fill nil :padding 5) :homogeneous t
 901      :child-args '(:padding 5)
 902      :child (make-instance 'check-button
 903              :label "Fill Tab" :active t
 904              :signal (list 'toggled
 905                            #'(lambda (button)
 906                                (setf
 907                                 (notebook-child-tab-fill-p page)
 908                                 (toggle-button-active-p button)))
 909                            :object t))
 910      :child (make-instance 'check-button
 911              :label "Expand Tab"
 912              :signal (list 'toggled
 913                            #'(lambda (button)
 914                                (setf
 915                                 (notebook-child-tab-expand-p page)
 916                                 (toggle-button-active-p button)))
 917                            :object t))
 918      :child (make-instance 'check-button
 919              :label "Pack end"
 920              :signal (list 'toggled
 921                            #'(lambda (button)
 922                                (setf
 923                                 (notebook-child-tab-pack page)
 924                                 (if (toggle-button-active-p button)
 925                                     :end
 926                                   :start)))
 927                            :object t))
 928      :child (make-instance 'button
 929              :label "Hide page"
 930              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 931
 932     (let ((label-box (make-instance 'h-box
 933                       :show-all t
 934                       :child-args '(:expand nil)
 935                       :child (make-instance 'image :pixmap book-closed-xpm)
 936                       :child (make-instance 'label :label title)))
 937           (menu-box (make-instance 'h-box
 938                      :show-all t
 939                      :child-args '(:expand nil)
 940                      :child (make-instance 'image :pixmap book-closed-xpm)
 941                      :child (make-instance 'label :label title))))
 942
 943       (widget-show-all page)
 944       (notebook-append notebook page label-box menu-box))))
 945
 946
 947 (define-simple-dialog create-notebook (dialog "Notebook")
 948   (let ((main (make-instance 'v-box :parent dialog)))
 949     (let ((notebook (make-instance 'notebook
 950                      :border-width 10 :tab-pos :top :parent main)))
 951       (flet ((set-image (page func xpm)
 952                (image-set-from-pixmap-data
 953                 (first (container-children (funcall func notebook page)))
 954                 xpm)))
 955         (signal-connect notebook 'switch-page
 956          #'(lambda (pointer page)
 957              (declare (ignore pointer))
 958              (unless (eq page (notebook-current-page-num notebook))
 959                (set-image page #'notebook-menu-label book-open-xpm)
 960                (set-image page #'notebook-tab-label book-open-xpm)
 961
 962                (let ((curpage (notebook-current-page notebook)))
 963                  (when curpage
 964                    (set-image curpage #'notebook-menu-label book-closed-xpm)
 965                    (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
 966       (loop for i from 1 to 5 do (create-notebook-page notebook i))
 967
 968       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 969
 970       (make-instance 'h-box
 971        :spacing 5 :border-width 10
 972        :parent (list main :expand nil)
 973        :child-args '(:fill nil)
 974        :child (make-instance 'check-button
 975                :label "Popup menu"
 976                :signal (list 'clicked
 977                         #'(lambda (button)
 978                             (if (toggle-button-active-p button)
 979                                 (notebook-popup-enable notebook)
 980                                 (notebook-popup-disable notebook)))
 981                         :object t))
 982        :child (make-instance 'check-button
 983                :label "Homogeneous tabs"
 984                :signal (list 'clicked
 985                         #'(lambda (button)
 986                             (setf
 987                              (notebook-homogeneous-p notebook)
 988                              (toggle-button-active-p button)))
 989                         :object t)))
 990
 991       (make-instance 'h-box
 992        :spacing 5 :border-width 10
 993        :parent (list main :expand nil)
 994        :child-args '(:expand nil)
 995        :child (make-instance 'label :label "Notebook Style: ")
 996        :child (let ((scrollable-p nil))
 997                 (create-option-menu
 998                  `(("Standard"
 999                     ,#'(lambda (menu-item)
1000                          (declare (ignore menu-item))
1001                          (setf (notebook-show-tabs-p notebook) t)
1002                          (when scrollable-p
1003                            (setq scrollable-p nil)
1004                            (setf (notebook-scrollable-p notebook) nil)
1005                            (loop repeat 10
1006                             do (notebook-remove-page notebook 5)))))
1007                    ("No tabs"
1008                     ,#'(lambda (menu-item)
1009                          (declare (ignore menu-item))
1010                          (setf (notebook-show-tabs-p notebook) nil)
1011                          (when scrollable-p
1012                            (setq scrollable-p nil)
1013                            (setf (notebook-scrollable-p notebook) nil)
1014                            (loop repeat 10
1015                             do (notebook-remove-page notebook 5)))))
1016                    ("Scrollable"
1017                     ,#'(lambda (menu-item)
1018                          (declare (ignore menu-item))
1019                          (unless scrollable-p
1020                            (setq scrollable-p t)
1021                            (setf (notebook-show-tabs-p notebook) t)
1022                            (setf (notebook-scrollable-p notebook) t)
1023                            (loop for i from 6 to 15
1024                             do (create-notebook-page notebook i))))))
1025                  0))
1026        :child (make-instance 'button
1027                :label "Show all Pages"
1028                :signal (list 'clicked
1029                         #'(lambda ()
1030                             (map-container nil #'widget-show notebook)))))
1031
1032       (make-instance 'h-box
1033        :spacing 5 :border-width 10
1034        :parent (list main :expand nil)
1035        :child (make-instance 'button
1036                :label "prev"
1037                :signal (list 'clicked #'notebook-prev-page :object notebook))
1038        :child (make-instance 'button
1039                :label "next"
1040                :signal (list 'clicked #'notebook-next-page :object notebook))
1041        :child (make-instance 'button
1042                :label "rotate"
1043                :signal (let ((tab-pos 0))
1044                          (list 'clicked
1045                           #'(lambda ()
1046                               (setq tab-pos (mod (1+ tab-pos) 4))
1047                               (setf
1048                                (notebook-tab-pos notebook)
1049                                (svref #(:top :right :bottom :left) tab-pos))))))))
1050     (widget-show-all main)))
1051
1052
1053 ;;; Panes
1054
1055 (defun toggle-resize (child)
1056   (let* ((paned (widget-parent child))
1057          (is-child1-p (eq child (paned-child1 paned))))
1058     (multiple-value-bind (child resize shrink)
1059         (if is-child1-p
1060             (paned-child1 paned)
1061           (paned-child2 paned))
1062       (container-remove paned child)
1063       (if is-child1-p
1064           (paned-pack1 paned child (not resize) shrink)
1065         (paned-pack2 paned child (not resize) shrink)))))
1066
1067 (defun toggle-shrink (child)
1068   (let* ((paned (widget-parent child))
1069          (is-child1-p (eq child (paned-child1 paned))))
1070     (multiple-value-bind (child resize shrink)
1071         (if is-child1-p
1072             (paned-child1 paned)
1073           (paned-child2 paned))
1074       (container-remove paned child)
1075       (if is-child1-p
1076           (paned-pack1 paned child resize (not shrink))
1077         (paned-pack2 paned child resize (not shrink))))))
1078
1079 (defun create-pane-options (paned frame-label label1 label2)
1080   (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
1081          (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
1082                                       :parent frame)))
1083
1084     (table-attach table (label-new label1) 0 1 0 1)
1085     (let ((check-button (make-instance 'check-button :label "Resize")))
1086       (table-attach table check-button 0 1 1 2)
1087       (signal-connect
1088        check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1089     (let ((check-button (make-instance 'check-button :label "Shrink")))
1090       (table-attach table check-button 0 1 2 3)
1091       (setf (toggle-button-active-p check-button) t)
1092       (signal-connect
1093        check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1094
1095     (table-attach table (label-new label2) 1 2 0 1)
1096     (let ((check-button (make-instance 'check-button :label "Resize")))
1097       (table-attach table check-button 1 2 1 2)
1098       (setf (toggle-button-active-p check-button) t)
1099       (signal-connect
1100        check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1101     (let ((check-button (make-instance 'check-button :label "Shrink")))
1102       (table-attach table check-button 1 2 2 3)
1103       (setf (toggle-button-active-p check-button) t)
1104       (signal-connect
1105        check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1106     frame))
1107
1108 (define-toplevel create-panes (window "Panes")
1109   (let* ((hpaned (make-instance 'h-paned
1110                   :child1 (make-instance 'frame
1111                            :width-request 60 :height-request 60
1112                            :shadow-type :in
1113                            :child (button-new "Hi there"))
1114                   :child2 (make-instance 'frame
1115                            :width-request 80 :height-request 60
1116                            :shadow-type :in)))
1117          (vpaned (make-instance 'v-paned
1118                   :border-width 5
1119                   :child1 hpaned
1120                   :child2 (make-instance 'frame
1121                            :width-request 80 :height-request 60
1122                            :shadow-type :in))))
1123
1124     (make-instance 'v-box
1125      :parent window
1126      :child-args '(:expand nil)
1127      :child (list vpaned :expand t)
1128      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1129      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1130
1131
1132 ;;; Progress bar
1133
1134
1135
1136
1137 ;;; Radio buttons
1138
1139 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1140   (make-instance 'v-box
1141    :parent dialog :border-width 10 :spacing 10 :show-all t
1142    :children (create-radio-button-group '("button1" "button2" "button3") 1)))
1143
1144
1145 ;;; Rangle controls
1146
1147 (define-simple-dialog create-range-controls (dialog "Range controls")
1148   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1149     (make-instance 'v-box
1150      :parent dialog :border-width 10 :spacing 10 :show-all t
1151      :child (make-instance 'h-scale
1152              :width-request 150 :adjustment adjustment :inverted t
1153              :update-policy :delayed :digits 1 :draw-value t)
1154      :child (make-instance 'h-scrollbar
1155              :adjustment adjustment :update-policy :continuous))))
1156
1157
1158 ;;; Reparent test
1159
1160 (define-simple-dialog create-reparent (dialog "Reparent")
1161   (let ((main (make-instance 'h-box
1162                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1163         (label (make-instance 'label :label "Hellow World")))
1164
1165     (flet ((create-frame (title)
1166              (let* ((frame (make-instance 'frame :label title :parent main))
1167                     (box (make-instance 'v-box
1168                           :spacing 5 :border-width 5 :parent frame))
1169                     (button (make-instance 'button
1170                              :label "switch" :parent (list box :expand nil))))
1171                (signal-connect button 'clicked
1172                 #'(lambda ()
1173                     (widget-reparent label box)))
1174                box)))
1175
1176       (box-pack-start (create-frame "Frame 1") label nil t 0)
1177       (create-frame "Frame 2"))
1178     (widget-show-all main)))
1179
1180
1181 ;;; Rulers
1182
1183 (define-toplevel create-rulers (window "Rulers"
1184                                 :default-width 300 :default-height 300
1185 ;;                              :events '(:pointer-motion-mask
1186 ;;                                        :pointer-motion-hint-mask)
1187                                 )
1188   (setf
1189    (widget-events window)
1190    '(:pointer-motion-mask :pointer-motion-hint-mask))
1191
1192   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
1193     (let ((ruler (make-instance 'h-ruler
1194                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1195                   :position 0.0d0 :max-size 20.0d0)))
1196       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1197       (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
1198     (let ((ruler (make-instance 'v-ruler
1199                   :lower 5.0d0 :upper 15.0d0
1200                   :position 0.0d0 :max-size 20.0d0)))
1201       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1202       (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
1203
1204
1205
1206 ;;; Scrolled window
1207
1208 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1209                                                       :default-width 300
1210                                                       :default-height 300)
1211   (let* ((scrolled-window
1212           (make-instance 'scrolled-window
1213            :parent dialog :border-width 10
1214            :vscrollbar-policy :automatic
1215            :hscrollbar-policy :automatic))
1216          (table
1217           (make-instance 'table
1218            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1219            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1220            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1221
1222       (scrolled-window-add-with-viewport scrolled-window table)
1223       (dotimes (i 20)
1224         (dotimes (j 20)
1225           (let ((button
1226                  (make-instance 'toggle-button
1227                   :label (format nil "button (~D,~D)~%" i j))))
1228             (table-attach table button i (1+ i) j (1+ j)))))
1229       (widget-show-all scrolled-window)))
1230
1231
1232 ;;; Shapes
1233
1234 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1235 ;;   (let* ((window
1236 ;;        (make-instance 'window
1237 ;;         :type type :x x :y y
1238 ;;         :events '(:button-motion :pointer-motion-hint :button-press)))
1239 ;;       (fixed
1240 ;;        (make-instance 'fixed
1241 ;;         :parent window :width 100 :height 100)))
1242
1243 ;;     (widget-realize window)
1244 ;;     (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1245 ;;       (let ((pixmap (pixmap-new source mask))
1246 ;;          (x-offset 0)
1247 ;;          (y-offset 0))
1248 ;;      (declare (fixnum x-offset y-offset))
1249 ;;      (fixed-put fixed pixmap px py)
1250 ;;      (widget-shape-combine-mask window mask px py)
1251
1252 ;;      (signal-connect window 'button-press-event
1253 ;;       #'(lambda (event)
1254 ;;           (when (typep event 'gdk:button-press-event)
1255 ;;             (setq x-offset (truncate (gdk:event-x event)))
1256 ;;             (setq y-offset (truncate (gdk:event-y event)))
1257 ;;             (grab-add window)
1258 ;;             (gdk:pointer-grab
1259 ;;              (widget-window window) t
1260 ;;              '(:button-release :button-motion :pointer-motion-hint)
1261 ;;              nil nil 0))
1262 ;;           t))
1263
1264 ;;      (signal-connect window 'button-release-event
1265 ;;       #'(lambda (event)
1266 ;;           (declare (ignore event))
1267 ;;           (grab-remove window)
1268 ;;           (gdk:pointer-ungrab 0)
1269 ;;           t))
1270
1271 ;;      (signal-connect window 'motion-notify-event
1272 ;;       #'(lambda (event)
1273 ;;           (declare (ignore event))
1274 ;;           (multiple-value-bind (win xp yp mask)
1275 ;;               (gdk:window-get-pointer root-window)
1276 ;;             (declare (ignore mask win) (fixnum xp yp))
1277 ;;             (widget-set-uposition
1278 ;;              window :x (- xp x-offset) :y (- yp y-offset)))
1279 ;;           t))
1280 ;;      (signal-connect window 'destroy destroy)))
1281
1282 ;;     (widget-show-all window)
1283 ;;     window))
1284
1285
1286 ;; (let ((modeller nil)
1287 ;;       (sheets nil)
1288 ;;       (rings nil))
1289 ;;   (defun create-shapes ()
1290 ;;     (let ((root-window (gdk:get-root-window)))
1291 ;;       (if (not modeller)
1292 ;;        (setq
1293 ;;         modeller
1294 ;;         (shape-create-icon
1295 ;;          "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1296 ;;          #'(lambda () (widget-destroyed modeller))))
1297 ;;      (widget-destroy modeller))
1298
1299 ;;       (if (not sheets)
1300 ;;        (setq
1301 ;;         sheets
1302 ;;         (shape-create-icon
1303 ;;          "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1304 ;;          #'(lambda () (widget-destroyed sheets))))
1305 ;;      (widget-destroy sheets))
1306
1307 ;;       (if (not rings)
1308 ;;        (setq
1309 ;;         rings
1310 ;;         (shape-create-icon
1311 ;;          "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1312 ;;          #'(lambda () (widget-destroyed rings))))
1313 ;;      (widget-destroy rings)))))
1314
1315
1316
1317 ;;; Spin buttons
1318
1319 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1320   (let ((main (make-instance 'v-box
1321                :spacing 5 :border-width 10 :parent dialog)))
1322
1323     (flet ((create-date-spinner (label adjustment shadow-type)
1324              (declare (ignore shadow-type))
1325              (make-instance 'v-box
1326               :child-args '(:expand nil)
1327               :child (make-instance 'label
1328                       :label label :xalign 0.0 :yalign 0.5)
1329               :child (make-instance 'spin-button
1330                       :adjustment adjustment :wrap t))))
1331       (make-instance 'frame
1332        :label "Not accelerated" :parent main
1333        :child (make-instance 'h-box
1334                :border-width 10
1335                :child-args '(:padding 5)
1336                :child (create-date-spinner "Day : "
1337                        (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1338                :child (create-date-spinner "Month : "
1339                        (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1340                :child (create-date-spinner "Year : "
1341                        (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1342
1343     (let ((spinner1 (make-instance 'spin-button
1344                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1345                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1346           (spinner2 (make-instance 'spin-button
1347                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1348                      :climb-rate 1.0 :wrap t))
1349           (value-label (make-instance 'label :label "0")))
1350       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1351        #'(lambda ()
1352            (setf
1353             (spin-button-digits spinner1)
1354             (floor (spin-button-value spinner2)))))
1355
1356       (make-instance 'frame
1357        :label "Accelerated" :parent main
1358        :child (make-instance 'v-box
1359                :border-width 5
1360                :child (list
1361                        (make-instance 'h-box
1362                         :child-args '(:padding 5)
1363                         :child (make-instance 'v-box
1364                                 :child (make-instance 'label
1365                                         :label "Value :"
1366                                         :xalign 0.0 :yalign 0.5)
1367                                 :child spinner1)
1368                         :child (make-instance 'v-box
1369                                 :child (make-instance 'label
1370                                         :label "Digits :"
1371                                         :xalign 0.0 :yalign 0.5)
1372                                 :child spinner2))
1373                        :expand nil :padding 5)
1374                :child (make-instance 'check-button
1375                        :label "Snap to 0.5-ticks" :active t
1376                        :signal (list 'clicked
1377                                 #'(lambda (button)
1378                                     (setf
1379                                      (spin-button-snap-to-ticks-p spinner1)
1380                                      (toggle-button-active-p button)))
1381                                 :object t))
1382                :child (make-instance 'check-button
1383                        :label "Numeric only input mode" :active t
1384                        :signal (list 'clicked
1385                                 #'(lambda (button)
1386                                     (setf
1387                                      (spin-button-numeric-p spinner1)
1388                                      (toggle-button-active-p button)))
1389                                 :object t))
1390                :child value-label
1391                :child (list
1392                        (make-instance 'h-box
1393                         :child-args '(:padding 5)
1394                         :child (make-instance 'button
1395                                 :label "Value as Int"
1396                                 :signal (list 'clicked
1397                                          #'(lambda ()
1398                                              (setf
1399                                               (label-label value-label)
1400                                               (format nil "~D"
1401                                                (spin-button-value-as-int
1402                                                 spinner1))))))
1403                         :child (make-instance 'button
1404                                 :label "Value as Float"
1405                                 :signal (list 'clicked
1406                                          #'(lambda ()
1407                                              (setf
1408                                               (label-label value-label)
1409                                               (format nil
1410                                                (format nil "~~,~DF"
1411                                                 (spin-button-digits spinner1))
1412                                                (spin-button-value spinner1)))))))
1413                        :padding 5 :expand nil))))
1414     (widget-show-all main)))
1415
1416
1417 ;;; Statusbar
1418
1419 (define-toplevel create-statusbar (window "Statusbar")
1420   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1421         (close-button (create-button '("close" :can-default t)
1422                        #'widget-destroy :object window))
1423         (counter 0))
1424
1425     (signal-connect statusbar 'text-popped
1426      #'(lambda (context-id text)
1427          (declare (ignore context-id))
1428          (format nil "Popped: ~A~%" text)))
1429
1430     (make-instance 'v-box
1431      :parent window
1432      :child (make-instance 'v-box
1433              :border-width 10 :spacing 10
1434              :child (create-button "push something"
1435                      #'(lambda ()
1436                          (statusbar-push statusbar 1
1437                           (format nil "something ~D" (incf counter)))))
1438              :child (create-button "pop"
1439                      #'(lambda ()
1440                          (statusbar-pop statusbar 1)))
1441              :child (create-button "steal #4"
1442                      #'(lambda ()
1443                          (statusbar-remove statusbar 1 4)))
1444              :child (create-button "dump stack")
1445              :child (create-button "test contexts"))
1446      :child (list (make-instance 'h-separator) :expand nil)
1447      :child (list
1448              (make-instance 'v-box :border-width 10 :child close-button)
1449              :expand nil)
1450      :child (list statusbar :expand nil))
1451
1452     (widget-grab-focus close-button)))
1453
1454
1455 ;;; Idle test
1456
1457 ;; (define-standard-dialog create-idle-test "Idle Test"
1458 ;;   (let* ((container (make-instance 'hbox :parent main-box))
1459 ;;       (label (make-instance 'label
1460 ;;               :label "count: 0" :xpad 10 :ypad 10 :parent container))
1461 ;;       (idle nil)
1462 ;;       (count 0))
1463 ;;     (declare (fixnum count))
1464 ;;     (signal-connect
1465 ;;      window 'destroy #'(lambda () (when idle (idle-remove idle))))
1466
1467 ;;     (make-instance 'frame
1468 ;;      :label "Label Container" :border-width 5 :parent main-box
1469 ;;      :child
1470 ;;      (make-instance 'v-box
1471 ;;       :children
1472 ;;       (create-radio-button-group
1473 ;;        '(("Resize-Parent" :parent)
1474 ;;       ("Resize-Queue" :queue)
1475 ;;       ("Resize-Immediate" :immediate))
1476 ;;        0
1477 ;;        '(setf container-resize-mode) container)))
1478
1479 ;;     (make-instance 'button
1480 ;;      :label "start" :can-default t :parent action-area
1481 ;;      :signals
1482 ;;      (list
1483 ;;       (list
1484 ;;        'clicked
1485 ;;        #'(lambda ()
1486 ;;         (unless idle
1487 ;;           (setq
1488 ;;            idle
1489 ;;            (idle-add
1490 ;;             #'(lambda ()
1491 ;;                 (incf count)
1492 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1493 ;;                 t))))))))
1494
1495 ;;     (make-instance 'button
1496 ;;      :label "stop" :can-default t :parent action-area
1497 ;;      :signals
1498 ;;      (list
1499 ;;       (list
1500 ;;        'clicked
1501 ;;        #'(lambda ()
1502 ;;         (when idle
1503 ;;           (idle-remove idle)
1504 ;;           (setq idle nil))))))))
1505
1506
1507
1508 ;;; Timeout test
1509
1510 ;; (define-standard-dialog create-timeout-test "Timeout Test"
1511 ;;   (let ((label (make-instance 'label
1512 ;;              :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1513 ;;      (timer nil)
1514 ;;      (count 0))
1515 ;;     (declare (fixnum count))
1516 ;;     (signal-connect
1517 ;;      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
1518
1519 ;;     (make-instance 'button
1520 ;;      :label "start" :can-default t :parent action-area
1521 ;;      :signals
1522 ;;      (list
1523 ;;       (list
1524 ;;        'clicked
1525 ;;        #'(lambda ()
1526 ;;         (unless timer
1527 ;;           (setq
1528 ;;            timer
1529 ;;            (timeout-add
1530 ;;             100
1531 ;;             #'(lambda ()
1532 ;;                 (incf count)
1533 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1534 ;;                 t))))))))
1535
1536 ;;     (make-instance 'button
1537 ;;      :label "stop" :can-default t :parent action-area
1538 ;;      :signals
1539 ;;      (list
1540 ;;       (list
1541 ;;        'clicked
1542 ;;        #'(lambda ()
1543 ;;         (when timer
1544 ;;           (timeout-remove timer)
1545 ;;           (setq timer nil))))))))
1546
1547
1548 ;;; Toggle buttons
1549
1550 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1551   (make-instance 'v-box
1552    :border-width 10 :spacing 10 :parent dialog :show-all t
1553       :children (loop
1554               for n from 1 to 3
1555               collect (make-instance 'toggle-button
1556                        :label (format nil "Button~D" (1+ n))))))
1557
1558
1559
1560 ;;; Toolbar test
1561
1562 ;; TODO: style properties
1563 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1564   (let ((toolbar (make-instance 'toolbar :parent window)))
1565 ;    (setf (toolbar-relief toolbar) :none)
1566
1567     ;; Insert a stock item
1568     (toolbar-append toolbar "gtk-quit"
1569      :tooltip-text "Destroy toolbar"
1570      :tooltip-private-text "Toolbar/Quit"
1571      :callback #'(lambda () (widget-destroy window)))
1572
1573     ;; Image widge as icon
1574     (toolbar-append toolbar "Horizontal"
1575      :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1576      :tooltip-text "Horizontal toolbar layout"
1577      :tooltip-private-text "Toolbar/Horizontal"
1578      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1579
1580     ;; Icon from file
1581     (toolbar-append toolbar "Vertical"
1582      :icon #p"clg:examples;test.xpm"
1583      :tooltip-text "Vertical toolbar layout"
1584      :tooltip-private-text "Toolbar/Vertical"
1585      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1586
1587     (toolbar-append toolbar :space)
1588
1589     ;; Stock icon
1590     (toolbar-append toolbar "Icons"
1591      :icon "gtk-execute"
1592      :tooltip-text "Only show toolbar icons"
1593      :tooltip-private-text "Toolbar/IconsOnly"
1594      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1595
1596     ;; Icon from pixmap data
1597     (toolbar-append toolbar "Text"
1598      :icon gtk-mini-xpm
1599      :tooltip-text "Only show toolbar text"
1600      :tooltip-private-text "Toolbar/TextOnly"
1601      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1602
1603     (toolbar-append toolbar "Both"
1604      :tooltip-text "Show toolbar icons and text"
1605      :tooltip-private-text "Toolbar/Both"
1606      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1607
1608     (toolbar-append toolbar :space)
1609
1610     (toolbar-append toolbar (make-instance 'entry)
1611      :tooltip-text "This is an unusable GtkEntry"
1612      :tooltip-private-text "Hey don't click me!")
1613
1614     (toolbar-append toolbar :space)
1615
1616 ;;     (toolbar-append-item
1617 ;;      toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1618 ;;      :tooltip-text "Use small spaces"
1619 ;;      :tooltip-private-text "Toolbar/Small"
1620 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1621
1622 ;;     (toolbar-append-item
1623 ;;      toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1624 ;;      :tooltip-text "Use big spaces"
1625 ;;      :tooltip-private-text "Toolbar/Big"
1626 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1627
1628 ;;     (toolbar-append toolbar :space)
1629
1630     (toolbar-append
1631      toolbar "Enable"
1632      :tooltip-text "Enable tooltips"
1633      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1634
1635     (toolbar-append
1636      toolbar "Disable"
1637      :tooltip-text "Disable tooltips"
1638      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1639
1640     (toolbar-append toolbar :space)
1641
1642 ;;     (toolbar-append-item
1643 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1644 ;;      :tooltip-text "Show borders"
1645 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1646
1647 ;;     (toolbar-append-item
1648 ;;      toolbar
1649 ;;      "Borderless" (pixmap-new "clg:examples;test.xpm")
1650 ;;      :tooltip-text "Hide borders"
1651 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1652
1653 ;;     (toolbar-append toolbar :space)
1654
1655 ;;     (toolbar-append-item
1656 ;;      toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1657 ;;      :tooltip-text "Empty spaces"
1658 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1659
1660 ;;     (toolbar-append-item
1661 ;;      toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1662 ;;      :tooltip-text "Lines in spaces"
1663 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1664
1665     ))
1666
1667
1668
1669 ;;; Tooltips test
1670
1671 ;; (define-standard-dialog create-tooltips "Tooltips"
1672 ;;   (setf
1673 ;;    (window-allow-grow-p window) t
1674 ;;    (window-allow-shrink-p window) nil
1675 ;;    (window-auto-shrink-p window) t
1676 ;;    (widget-width window) 200
1677 ;;    (container-border-width main-box) 10
1678 ;;    (box-spacing main-box) 10)
1679
1680 ;;   (let ((tooltips (tooltips-new)))
1681 ;;     (flet ((create-button (label tip-text tip-private)
1682 ;;           (let ((button (make-instance 'toggle-button
1683 ;;                  :label label :parent main-box)))
1684 ;;             (tooltips-set-tip tooltips button tip-text tip-private)
1685 ;;             button)))
1686 ;;       (create-button "button1" "This is button 1" "ContextHelp/button/1")
1687 ;;       (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")
1688
1689 ;;       (let* ((toggle (create-button "Override TipSQuery Label"
1690 ;;                                  "Toggle TipsQuery view" "Hi msw! ;)"))
1691 ;;           (box (make-instance 'v-box
1692 ;;                 :homogeneous nil :spacing 5 :border-width 5
1693 ;;                 :parent (make-instance 'frame
1694 ;;                          :label "ToolTips Inspector"
1695 ;;                          :label-xalign 0.5 :border-width 0
1696 ;;                          :parent main-box)))
1697 ;;           (button (make-instance 'button :label "[?]" :parent box))
1698 ;;           (tips-query (make-instance 'tips-query
1699 ;;                        :caller button :parent box)))
1700
1701 ;;      (signal-connect
1702 ;;       button 'clicked #'tips-query-start-query :object tips-query)
1703
1704 ;;      (signal-connect
1705 ;;       tips-query 'widget-entered
1706 ;;       #'(lambda (widget tip-text tip-private)
1707 ;;           (declare (ignore widget tip-private))
1708 ;;           (when (toggle-button-active-p toggle)
1709 ;;             (setf
1710 ;;              (label-label tips-query)
1711 ;;              (if tip-text
1712 ;;                  "There is a Tip!"
1713 ;;                "There is no Tip!"))
1714 ;;             (signal-emit-stop tips-query 'widget-entered))))
1715
1716 ;;      (signal-connect
1717 ;;       tips-query 'widget-selected
1718 ;;       #'(lambda (widget tip-text tip-private event)
1719 ;;           (declare (ignore tip-text event))
1720 ;;           (when widget
1721 ;;             (format
1722 ;;              t "Help ~S requested for ~S~%"
1723 ;;              (or tip-private "None") (type-of widget)))
1724 ;;           t))
1725
1726 ;;      (tooltips-set-tip
1727 ;;       tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1728 ;;      (tooltips-set-tip
1729 ;;       tooltips close-button "Push this button to close window"
1730 ;;       "ContextHelp/buttons/Close")))))
1731
1732
1733
1734 ;;; Main window
1735
1736 (defun create-main-window ()
1737 ;;   (rc-parse "clg:examples;testgtkrc2")
1738 ;;   (rc-parse "clg:examples;testgtkrc")
1739
1740   (let* ((button-specs
1741           '(("button box" create-button-box)
1742             ("buttons" create-buttons)
1743             ("calendar" create-calendar)
1744             ("check buttons" create-check-buttons)
1745 ;;          ("clist" #|create-clist|#)
1746             ("color selection" create-color-selection)
1747 ;;          ("ctree" #|create-ctree|#)
1748 ;;          ("cursors" #|create-cursors|#)
1749             ("dialog" create-dialog)
1750 ;; ;        ("dnd")
1751             ("entry" create-entry)
1752 ;;          ("event watcher")
1753             ("file chooser" create-file-chooser)
1754 ;;          ("font selection")
1755 ;;          ("handle box" create-handle-box)
1756             ("image" create-image)
1757 ;;          ("item factory")
1758             ("labels" create-labels)
1759             ("layout" create-layout)
1760 ;;          ("list" create-list)
1761             ("menus" create-menus)
1762 ;;          ("modal window")
1763             ("notebook" create-notebook)
1764             ("panes" create-panes)
1765 ;;          ("preview color")
1766 ;;          ("preview gray")
1767 ;;          ("progress bar" #|create-progress-bar|#)
1768             ("radio buttons" create-radio-buttons)
1769             ("range controls" create-range-controls)
1770 ;;          ("rc file")
1771             ("reparent" create-reparent)
1772             ("rulers" create-rulers)
1773 ;;          ("saved position")
1774             ("scrolled windows" create-scrolled-windows)
1775 ;;          ("shapes" create-shapes)
1776             ("spinbutton" create-spins)
1777             ("statusbar" create-statusbar)
1778 ;;          ("test idle" create-idle-test)
1779 ;;          ("test mainloop")
1780 ;;          ("test scrolling")
1781 ;;          ("test selection")
1782 ;;          ("test timeout" create-timeout-test)
1783 ;;          ("text" #|create-text|#)
1784             ("toggle buttons" create-toggle-buttons)
1785             ("toolbar" create-toolbar)
1786 ;;          ("tooltips" create-tooltips)
1787 ;;          ("tree" #|create-tree|#)
1788 ))
1789         (main-window (make-instance 'window
1790                       :title "testgtk.lisp" :name "main_window"
1791                       :default-width 200 :default-height 400
1792                       :allow-grow t :allow-shrink nil))
1793         (scrolled-window (make-instance 'scrolled-window
1794                           :hscrollbar-policy :automatic
1795                           :vscrollbar-policy :automatic
1796                           :border-width 10))
1797         (close-button (make-instance 'button
1798                        :label "close" :can-default t
1799                        :signal (list 'clicked #'widget-destroy
1800                                      :object main-window))))
1801
1802     ;; Main box
1803     (make-instance 'v-box
1804      :parent main-window
1805      :child-args '(:expand nil)
1806      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1807      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1808      :child (list scrolled-window :expand t)
1809      :child (make-instance 'h-separator)
1810      :child (make-instance 'v-box
1811              :homogeneous nil :spacing 10 :border-width 10
1812              :child close-button))
1813
1814     (let ((content-box
1815            (make-instance 'v-box
1816             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1817             :children (mapcar #'(lambda (spec)
1818                                   (apply #'create-button spec))
1819                               button-specs))))
1820       (scrolled-window-add-with-viewport scrolled-window content-box))
1821
1822     (widget-grab-focus close-button)
1823     (widget-show-all main-window)
1824     main-window))
1825
1826 (clg-init)
1827 (create-main-window)