mdw@git.distorted.org.uk Git - 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.9 2004-12-05 00:06:41 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 "gtk-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 "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-standard-dialog create-idle-test "Idle Test"
1439 ;;   (let* ((container (make-instance 'hbox :parent main-box))
1440 ;;       (label (make-instance 'label
1441 ;;               :label "count: 0" :xpad 10 :ypad 10 :parent container))
1442 ;;       (idle nil)
1443 ;;       (count 0))
1444 ;;     (declare (fixnum count))
1445 ;;     (signal-connect
1446 ;;      window 'destroy #'(lambda () (when idle (idle-remove idle))))
1447
1448 ;;     (make-instance 'frame
1449 ;;      :label "Label Container" :border-width 5 :parent main-box
1450 ;;      :child
1451 ;;      (make-instance 'v-box
1452 ;;       :children
1453 ;;       (create-radio-button-group
1454 ;;        '(("Resize-Parent" :parent)
1455 ;;       ("Resize-Queue" :queue)
1456 ;;       ("Resize-Immediate" :immediate))
1457 ;;        0
1458 ;;        '(setf container-resize-mode) container)))
1459
1460 ;;     (make-instance 'button
1461 ;;      :label "start" :can-default t :parent action-area
1462 ;;      :signals
1463 ;;      (list
1464 ;;       (list
1465 ;;        'clicked
1466 ;;        #'(lambda ()
1467 ;;         (unless idle
1468 ;;           (setq
1469 ;;            idle
1470 ;;            (idle-add
1471 ;;             #'(lambda ()
1472 ;;                 (incf count)
1473 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1474 ;;                 t))))))))
1475
1476 ;;     (make-instance 'button
1477 ;;      :label "stop" :can-default t :parent action-area
1478 ;;      :signals
1479 ;;      (list
1480 ;;       (list
1481 ;;        'clicked
1482 ;;        #'(lambda ()
1483 ;;         (when idle
1484 ;;           (idle-remove idle)
1485 ;;           (setq idle nil))))))))
1486
1487
1488
1489 ;;; Timeout test
1490
1491 ;; (define-standard-dialog create-timeout-test "Timeout Test"
1492 ;;   (let ((label (make-instance 'label
1493 ;;              :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1494 ;;      (timer nil)
1495 ;;      (count 0))
1496 ;;     (declare (fixnum count))
1497 ;;     (signal-connect
1498 ;;      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
1499
1500 ;;     (make-instance 'button
1501 ;;      :label "start" :can-default t :parent action-area
1502 ;;      :signals
1503 ;;      (list
1504 ;;       (list
1505 ;;        'clicked
1506 ;;        #'(lambda ()
1507 ;;         (unless timer
1508 ;;           (setq
1509 ;;            timer
1510 ;;            (timeout-add
1511 ;;             100
1512 ;;             #'(lambda ()
1513 ;;                 (incf count)
1514 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1515 ;;                 t))))))))
1516
1517 ;;     (make-instance 'button
1518 ;;      :label "stop" :can-default t :parent action-area
1519 ;;      :signals
1520 ;;      (list
1521 ;;       (list
1522 ;;        'clicked
1523 ;;        #'(lambda ()
1524 ;;         (when timer
1525 ;;           (timeout-remove timer)
1526 ;;           (setq timer nil))))))))
1527
1528
1529 ;;; Text
1530
1531 (define-simple-dialog create-text (dialog "Text" :default-width 400
1532                                                  :default-height 400)
1533   (make-instance 'text-view :border-width 10  :parent dialog :visible t))
1534
1535 ;;; Toggle buttons
1536
1537 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1538   (make-instance 'v-box
1539    :border-width 10 :spacing 10 :parent dialog :show-all t
1540       :children (loop
1541               for n from 1 to 3
1542               collect (make-instance 'toggle-button
1543                        :label (format nil "Button~D" (1+ n))))))
1544
1545
1546
1547 ;;; Toolbar test
1548
1549 ;; TODO: style properties
1550 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1551   (let ((toolbar (make-instance 'toolbar :parent window)))
1552 ;    (setf (toolbar-relief toolbar) :none)
1553
1554     ;; Insert a stock item
1555     (toolbar-append toolbar "gtk-quit"
1556      :tooltip-text "Destroy toolbar"
1557      :tooltip-private-text "Toolbar/Quit"
1558      :callback #'(lambda () (widget-destroy window)))
1559
1560     ;; Image widge as icon
1561     (toolbar-append toolbar "Horizontal"
1562      :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1563      :tooltip-text "Horizontal toolbar layout"
1564      :tooltip-private-text "Toolbar/Horizontal"
1565      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1566
1567     ;; Icon from file
1568     (toolbar-append toolbar "Vertical"
1569      :icon #p"clg:examples;test.xpm"
1570      :tooltip-text "Vertical toolbar layout"
1571      :tooltip-private-text "Toolbar/Vertical"
1572      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1573
1574     (toolbar-append toolbar :space)
1575
1576     ;; Stock icon
1577     (toolbar-append toolbar "Icons"
1578      :icon "gtk-execute"
1579      :tooltip-text "Only show toolbar icons"
1580      :tooltip-private-text "Toolbar/IconsOnly"
1581      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1582
1583     ;; Icon from pixmap data
1584     (toolbar-append toolbar "Text"
1585      :icon gtk-mini-xpm
1586      :tooltip-text "Only show toolbar text"
1587      :tooltip-private-text "Toolbar/TextOnly"
1588      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1589
1590     (toolbar-append toolbar "Both"
1591      :tooltip-text "Show toolbar icons and text"
1592      :tooltip-private-text "Toolbar/Both"
1593      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1594
1595     (toolbar-append toolbar :space)
1596
1597     (toolbar-append toolbar (make-instance 'entry)
1598      :tooltip-text "This is an unusable GtkEntry"
1599      :tooltip-private-text "Hey don't click me!")
1600
1601     (toolbar-append toolbar :space)
1602
1603 ;;     (toolbar-append-item
1604 ;;      toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1605 ;;      :tooltip-text "Use small spaces"
1606 ;;      :tooltip-private-text "Toolbar/Small"
1607 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1608
1609 ;;     (toolbar-append-item
1610 ;;      toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1611 ;;      :tooltip-text "Use big spaces"
1612 ;;      :tooltip-private-text "Toolbar/Big"
1613 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1614
1615 ;;     (toolbar-append toolbar :space)
1616
1617     (toolbar-append
1618      toolbar "Enable"
1619      :tooltip-text "Enable tooltips"
1620      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1621
1622     (toolbar-append
1623      toolbar "Disable"
1624      :tooltip-text "Disable tooltips"
1625      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1626
1627     (toolbar-append toolbar :space)
1628
1629 ;;     (toolbar-append-item
1630 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1631 ;;      :tooltip-text "Show borders"
1632 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1633
1634 ;;     (toolbar-append-item
1635 ;;      toolbar
1636 ;;      "Borderless" (pixmap-new "clg:examples;test.xpm")
1637 ;;      :tooltip-text "Hide borders"
1638 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1639
1640 ;;     (toolbar-append toolbar :space)
1641
1642 ;;     (toolbar-append-item
1643 ;;      toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1644 ;;      :tooltip-text "Empty spaces"
1645 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1646
1647 ;;     (toolbar-append-item
1648 ;;      toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1649 ;;      :tooltip-text "Lines in spaces"
1650 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1651
1652     ))
1653
1654
1655
1656 ;;; Tooltips test
1657
1658 ;; (define-standard-dialog create-tooltips "Tooltips"
1659 ;;   (setf
1660 ;;    (window-allow-grow-p window) t
1661 ;;    (window-allow-shrink-p window) nil
1662 ;;    (window-auto-shrink-p window) t
1663 ;;    (widget-width window) 200
1664 ;;    (container-border-width main-box) 10
1665 ;;    (box-spacing main-box) 10)
1666
1667 ;;   (let ((tooltips (tooltips-new)))
1668 ;;     (flet ((create-button (label tip-text tip-private)
1669 ;;           (let ((button (make-instance 'toggle-button
1670 ;;                  :label label :parent main-box)))
1671 ;;             (tooltips-set-tip tooltips button tip-text tip-private)
1672 ;;             button)))
1673 ;;       (create-button "button1" "This is button 1" "ContextHelp/button/1")
1674 ;;       (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")
1675
1676 ;;       (let* ((toggle (create-button "Override TipSQuery Label"
1677 ;;                                  "Toggle TipsQuery view" "Hi msw! ;)"))
1678 ;;           (box (make-instance 'v-box
1679 ;;                 :homogeneous nil :spacing 5 :border-width 5
1680 ;;                 :parent (make-instance 'frame
1681 ;;                          :label "ToolTips Inspector"
1682 ;;                          :label-xalign 0.5 :border-width 0
1683 ;;                          :parent main-box)))
1684 ;;           (button (make-instance 'button :label "[?]" :parent box))
1685 ;;           (tips-query (make-instance 'tips-query
1686 ;;                        :caller button :parent box)))
1687
1688 ;;      (signal-connect
1689 ;;       button 'clicked #'tips-query-start-query :object tips-query)
1690
1691 ;;      (signal-connect
1692 ;;       tips-query 'widget-entered
1693 ;;       #'(lambda (widget tip-text tip-private)
1694 ;;           (declare (ignore widget tip-private))
1695 ;;           (when (toggle-button-active-p toggle)
1696 ;;             (setf
1697 ;;              (label-label tips-query)
1698 ;;              (if tip-text
1699 ;;                  "There is a Tip!"
1700 ;;                "There is no Tip!"))
1701 ;;             (signal-emit-stop tips-query 'widget-entered))))
1702
1703 ;;      (signal-connect
1704 ;;       tips-query 'widget-selected
1705 ;;       #'(lambda (widget tip-text tip-private event)
1706 ;;           (declare (ignore tip-text event))
1707 ;;           (when widget
1708 ;;             (format
1709 ;;              t "Help ~S requested for ~S~%"
1710 ;;              (or tip-private "None") (type-of widget)))
1711 ;;           t))
1712
1713 ;;      (tooltips-set-tip
1714 ;;       tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1715 ;;      (tooltips-set-tip
1716 ;;       tooltips close-button "Push this button to close window"
1717 ;;       "ContextHelp/buttons/Close")))))
1718
1719
1720 ;;; UI Manager
1721
1722 (defvar *ui-description*
1723   '((:menubar "MenuBar"
1724      (:menu "FileMenu"
1725       (:menuitem "New")
1726       (:menuitem "Open")
1727       (:menuitem "Save")
1728       (:menuitem "SaveAs")
1729       :separator
1730       (:menuitem "Quit"))
1731      (:menu "PreferencesMenu"
1732        (:menu "ColorMenu"
1733         (:menuitem "Red")
1734         (:menuitem "Green")
1735         (:menuitem "Blue"))
1736        (:menu "ShapeMenu"
1737         (:menuitem "Square")
1738         (:menuitem "Rectangle")
1739         (:menuitem "Oval"))
1740        (:menuitem "Bold"))
1741      (:menu "HelpMenu"
1742       (:menuitem "About")))
1743     (:toolbar "ToolBar"
1744      (:toolitem "Open")
1745      (:toolitem "Quit")
1746      (:separator "Sep1")
1747      (:toolitem "Logo"))))
1748
1749 (define-simple-dialog create-ui-manager (dialog "UI Manager")
1750   (let ((actions
1751          (make-instance 'action-group
1752           :name "Actions"
1753           :action (create-action "FileMenu" nil "_File")
1754           :action (create-action "PreferencesMenu" nil "_Preferences")
1755           :action (create-action "ColorMenu" nil "_Color")
1756           :action (create-action "ShapeMenu" nil "_Shape")
1757           :action (create-action "HelpMenu" nil "_Help")
1758           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1759           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
1760           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1761           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1762           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
1763           :action (create-action "About" nil "_About" "<control>A" "About")
1764           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1765           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1766           :actions (create-radio-actions
1767                     '(("Red" nil "_Red" "<control>R" "Blood")
1768                       ("Green" nil "_Green" "<control>G" "Grass")
1769                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1770                     "Green")
1771           :actions (create-radio-actions
1772                     '(("Square" nil "_Square" "<control>S" "Square")
1773                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1774                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1775         (ui (make-instance 'ui-manager)))
1776
1777     (ui-manager-insert-action-group ui actions)
1778     (ui-manager-add-ui ui *ui-description*)
1779
1780     (window-add-accel-group dialog (ui-manager-accel-group ui))
1781
1782     (make-instance 'v-box
1783      :parent dialog :show-all t
1784      :child (list
1785              (ui-manager-get-widget ui "/MenuBar")
1786              :expand nil :fill nil)
1787      :child (list
1788              (ui-manager-get-widget ui "/ToolBar")
1789              :expand nil :fill nil)
1790      :child (make-instance 'label
1791              :label "Type <alt> to start"
1792              :xalign 0.5 :yalign 0.5
1793              :width-request 200 :height-request 200))))
1794
1795
1796
1797 ;;; Main window
1798
1799 (defun create-main-window ()
1800 ;;   (rc-parse "clg:examples;testgtkrc2")
1801 ;;   (rc-parse "clg:examples;testgtkrc")
1802
1803   (let* ((button-specs
1804           '(("button box" create-button-box)
1805             ("buttons" create-buttons)
1806             ("calendar" create-calendar)
1807             ("check buttons" create-check-buttons)
1808             ("color selection" create-color-selection)
1809 ;;          ("cursors" #|create-cursors|#)
1810             ("dialog" create-dialog)
1811 ;; ;        ("dnd")
1812             ("entry" create-entry)
1813 ;;          ("event watcher")
1814             ("enxpander" create-expander)
1815             ("file chooser" create-file-chooser)
1816 ;;          ("font selection")
1817 ;;          ("handle box" create-handle-box)
1818             ("image" create-image)
1819 ;;          ("item factory")
1820             ("labels" create-labels)
1821             ("layout" create-layout)
1822             ("list" create-list)
1823             ("menus" create-menus)
1824 ;;          ("modal window")
1825             ("notebook" create-notebook)
1826             ("panes" create-panes)
1827 ;;          ("progress bar" #|create-progress-bar|#)
1828             ("radio buttons" create-radio-buttons)
1829             ("range controls" create-range-controls)
1830 ;;          ("rc file")
1831             ("reparent" create-reparent)
1832             ("rulers" create-rulers)
1833 ;;          ("saved position")
1834             ("scrolled windows" create-scrolled-windows)
1835 ;;          ("shapes" create-shapes)
1836             ("spinbutton" create-spins)
1837             ("statusbar" create-statusbar)
1838 ;;          ("test idle" create-idle-test)
1839 ;;          ("test mainloop")
1840 ;;          ("test scrolling")
1841 ;;          ("test selection")
1842 ;;          ("test timeout" create-timeout-test)
1843             ("text" create-text)
1844             ("toggle buttons" create-toggle-buttons)
1845             ("toolbar" create-toolbar)
1846 ;;          ("tooltips" create-tooltips)
1847 ;;          ("tree" #|create-tree|#)
1848             ("UI manager" create-ui-manager)
1849 ))
1850         (main-window (make-instance 'window
1851                       :title "testgtk.lisp" :name "main_window"
1852                       :default-width 200 :default-height 400
1853                       :allow-grow t :allow-shrink nil))
1854         (scrolled-window (make-instance 'scrolled-window
1855                           :hscrollbar-policy :automatic
1856                           :vscrollbar-policy :automatic
1857                           :border-width 10))
1858         (close-button (make-instance 'button
1859                        :label "close" :can-default t
1860                        :signal (list 'clicked #'widget-destroy
1861                                      :object main-window))))
1862
1863     ;; Main box
1864     (make-instance 'v-box
1865      :parent main-window
1866      :child-args '(:expand nil)
1867      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1868      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1869      :child (list scrolled-window :expand t)
1870      :child (make-instance 'h-separator)
1871      :child (make-instance 'v-box
1872              :homogeneous nil :spacing 10 :border-width 10
1873              :child close-button))
1874
1875     (let ((content-box
1876            (make-instance 'v-box
1877             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1878             :children (mapcar #'(lambda (spec)
1879                                   (apply #'create-button spec))
1880                               button-specs))))
1881       (scrolled-window-add-with-viewport scrolled-window content-box))
1882
1883     (widget-grab-focus close-button)
1884     (widget-show-all main-window)
1885     main-window))
1886
1887 (clg-init)
1888 (create-main-window)